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)