Add font compression

app/Main.hs

@@ -2,36 +2,52 @@ module Main
     ( main
     ) where
 
-import Data.Bifunctor (Bifunctor(..))
-import qualified Text.Megaparsec as Megaparsec
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.IO as Text.Lazy
-import Graphics.Fountainhead (parseFontDirectoryFromFile)
-import Graphics.Fountainhead.Dumper (DumpError(..), dumpTables)
--- TODO: kern table since format 1.
--- For details on subtable format see examples in TrueType reference.
-import System.Environment (getArgs)
+import Graphics.Fountainhead (dumpFontFile)
 import System.Exit (exitWith)
 import GHC.IO.Exception (ExitCode(..))
+import Options.Applicative
+    ( Parser
+    , ParserInfo(..)
+    , argument
+    , command
+    , execParser
+    , info
+    , fullDesc
+    , metavar
+    , progDesc
+    , str
+    , subparser
+    )
 
-fontMain :: FilePath -> IO ()
-fontMain fontFile = do
-    putStrLn ("Dumping File:" <> fontFile <> "\n\n")
+data Operation
+    = Dump FilePath
+    | Afm FilePath
+    deriving (Eq, Show)
 
-    (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
+dump :: Parser Operation
+dump = Dump
+    <$> argument str (metavar "FONTFILE")
 
-    case first DumpParseError initialResult >>= dumpTables processedState of
-        Right fontDump -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump
-        Left e
-            | DumpParseError bundle <- e -> putStr
-                $ Megaparsec.errorBundlePretty bundle
-            | DumpRequiredTableMissingError tableName <- e -> putStr
-                $ "Required table " <> tableName <> " is missing."
+afm :: Parser Operation
+afm = Afm
+    <$> argument str (metavar "FONTFILE")
+
+operationOptions :: ParserInfo Operation
+operationOptions = info commands fullDesc
+  where
+    commands = subparser
+        $ command "dump" (info dump (progDesc "Dumping the contents of a TrueType Font file"))
+        <> command "afm" (info afm (progDesc "Generating Adobe Font Metrics files for TrueType fonts"))
 
 main :: IO ()
-main = do
-    programArguments <- getArgs
-    case programArguments of
-        [fontFile] -> fontMain fontFile
-        _ -> putStrLn "The program expects exactly one argument, the font file path."
-            >> exitWith (ExitFailure 2)
+main = execParser operationOptions >>= handleArguments
+  where
+    handleArguments (Dump fontFile)
+        = putStrLn ("Dumping File:" <> fontFile <> "\n\n")
+        >> dumpFontFile fontFile
+        >>= either print (Text.Lazy.putStrLn . Text.Builder.toLazyText)
+    handleArguments (Afm _)
+        = putStrLn "The program expects exactly one argument, the font file path."
+        >> exitWith (ExitFailure 2)

fountainhead.cabal

@@ -12,7 +12,7 @@ author: Eugen Wissner
 license-files: LICENSE
 license: MPL-2.0
 
-copyright: (c) 2023 Eugen Wissner
+copyright: (c) 2024 Eugen Wissner
 category: Graphics
 
 extra-source-files:
@@ -21,6 +21,7 @@ extra-source-files:
 
 common dependencies
   build-depends:
+    base >= 4.16 && < 5,
     bytestring ^>= 0.11.0,
     text ^>= 2.0,
     zlib ^>= 0.6.3
@@ -30,13 +31,13 @@ library
   import: dependencies
   exposed-modules:
     Graphics.Fountainhead
+    Graphics.Fountainhead.Compression
     Graphics.Fountainhead.Dumper
     Graphics.Fountainhead.Parser
     Graphics.Fountainhead.Type
     Graphics.Fountainhead.TrueType
-  hs-source-dirs: src
+  hs-source-dirs: lib
   build-depends:
-    base >= 4.16 && < 5,
     containers ^>= 0.6.5,
     megaparsec ^>= 9.3,
     time ^>= 1.12,
@@ -53,13 +54,13 @@ executable fountainhead
     DuplicateRecordFields
     ExplicitForAll
   build-depends:
-    base,
     containers,
+    fountainhead,
+    megaparsec,
+    optparse-applicative ^>= 0.18.1,
     parser-combinators,
     vector,
     transformers,
-    time,
-    megaparsec,
-    fountainhead
+    time
   hs-source-dirs: app
   ghc-options: -Wall

lib/Graphics/Fountainhead.hs

@@ -2,28 +2,31 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+-- | Convenience wrappers for working with font files.
 module Graphics.Fountainhead
-    ( parseFontDirectoryFromFile
+    ( dumpFontFile
+    , parseFontDirectoryFromFile
     ) where
 
-import qualified Codec.Compression.Zlib as Zlib
 import Data.ByteString (ByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Lazy as ByteString.Lazy
 import Data.Void (Void)
+import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..))
 import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
 import Graphics.Fountainhead.TrueType (FontDirectory(..))
 import qualified Text.Megaparsec as Megaparsec
 import Text.Megaparsec (PosState(..), State(..))
-import System.IO (IOMode(..), SeekMode(..), hFileSize, hSeek, withBinaryFile)
+import System.IO (IOMode(..), withBinaryFile)
+import Data.Bifunctor (Bifunctor(..))
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import Graphics.Fountainhead.Compression (hDecompress)
 
-parseFontDirectoryFromFile :: String
+parseFontDirectoryFromFile :: FilePath
     -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
 parseFontDirectoryFromFile fontFile =
     withBinaryFile fontFile ReadMode withFontHandle
   where
     withFontHandle fontHandle = doParsing
-        <$> readFontContents fontHandle
+        <$> hDecompress fontHandle
     doParsing ttfContents =
         let initialState = Megaparsec.State
                 { stateInput = ttfContents
@@ -38,13 +41,9 @@ parseFontDirectoryFromFile fontFile =
                 , stateParseErrors = []
                 }
          in Megaparsec.runParser' fontDirectoryP initialState 
-    readFontContents fontHandle = do
-        firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2
-        hSeek fontHandle AbsoluteSeek 0
-        fileSize <- fromIntegral <$> hFileSize fontHandle
-        case firstBytes of
-            0x78 : [secondByte]
-                | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] ->
-                    ByteString.Lazy.toStrict . Zlib.decompress
-                        <$> ByteString.Lazy.hGet fontHandle fileSize
-            _ -> ByteString.hGetContents fontHandle
+
+dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
+dumpFontFile fontFile = do
+    (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
+
+    pure $ first DumpParseError initialResult >>= dumpTables processedState

lib/Graphics/Fountainhead/Compression.hs

@@ -0,0 +1,27 @@
+-- | Font compression and decompression.
+module Graphics.Fountainhead.Compression
+    ( compress
+    , hDecompress
+    ) where
+
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Codec.Compression.Zlib as Zlib
+import System.IO (Handle, SeekMode(..), hFileSize, hSeek)
+
+-- | Reads the font from a file handle decompressing it if needed.
+hDecompress :: Handle -> IO ByteString
+hDecompress fontHandle = do
+    firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2
+    hSeek fontHandle AbsoluteSeek 0
+    fileSize <- fromIntegral <$> hFileSize fontHandle
+    case firstBytes of
+        0x78 : [secondByte]
+            | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] ->
+                ByteString.Lazy.toStrict . Zlib.decompress
+                    <$> ByteString.Lazy.hGet fontHandle fileSize
+        _ -> ByteString.hGetContents fontHandle
+
+compress :: ByteString -> ByteString
+compress = ByteString.Lazy.toStrict . Zlib.compress . ByteString.Lazy.fromStrict

lib/Graphics/Fountainhead/Dumper.hs

@@ -127,6 +127,13 @@ import Prelude hiding (repeat)
 data DumpError
     = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
     | DumpRequiredTableMissingError String
+    deriving Eq
+
+instance Show DumpError
+  where
+    show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
+    show (DumpRequiredTableMissingError tableName) =
+        "Required table " <> tableName <> " is missing."
 
 data RequiredTables = RequiredTables
     { hheaTable :: HheaTable