Add an option for dumping a single table

README.md

@@ -1,4 +1,4 @@
-# TrueType font parser.
+# TrueType font parser
 
 Fountainhead is a TrueType and OpenType font parser. Its main
 purpose is to extract information from the fonts to help to
@@ -10,24 +10,27 @@ There is also an executable to dump fonts.
 ## Installation
 
 Add the library as dependency to your project.
-Alternatively build and run the executable with:
+Alternatively build an executable with:
 
 ```sh
 cabal build
 ```
 
-The binary can be executed with:
+The binary can be run with:
 
 ```sh
-cabal run fountainhead --
+cabal run fountainhead -- myfont.ttf
 ```
 
 or installed locally and executed just as:
 
 ```sh
-fountainhead
+fountainhead myfont.ttf
 ```
 
+This command will output the contents of the font in a format similar to
+ttfdump from TeXLive.
+
 See
 
 ```sh

lib/Graphics/Fountainhead.hs

@@ -10,7 +10,7 @@ module Graphics.Fountainhead
 
 import Data.ByteString (ByteString)
 import Data.Void (Void)
-import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..))
+import Graphics.Fountainhead.Dumper (dumpTable, dumpTables, DumpError(..))
 import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
 import Graphics.Fountainhead.TrueType (FontDirectory(..))
 import qualified Text.Megaparsec as Megaparsec
@@ -42,8 +42,8 @@ parseFontDirectoryFromFile fontFile =
                 }
          in Megaparsec.runParser' fontDirectoryP initialState 
 
-dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
+dumpFontFile :: FilePath -> Maybe String -> IO (Either DumpError Text.Builder.Builder)
-dumpFontFile fontFile = do
+dumpFontFile fontFile tableName = do
+    let dumpRequest = maybe dumpTables dumpTable tableName
     (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
-
+    pure $ first DumpParseError initialResult >>= dumpRequest processedState
-    pure $ first DumpParseError initialResult >>= dumpTables processedState

lib/Graphics/Fountainhead/Dumper.hs

@@ -14,6 +14,7 @@
 module Graphics.Fountainhead.Dumper
     ( DumpError(..)
     , dumpCmap
+    , dumpGASP
     , dumpGlyf
     , dumpHead
     , dumpHmtx
@@ -23,6 +24,7 @@ module Graphics.Fountainhead.Dumper
     , dumpMaxp
     , dumpOs2
     , dumpPost
+    , dumpTable
     , dumpTables
     , dumpTrueType
     , dumpOffsetTable
@@ -95,7 +97,9 @@ import Graphics.Fountainhead.TrueType
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
-    ( fontDirectoryP
+    ( ParseErrorBundle
+    , ParseState
+    , fontDirectoryP
     , parseTable
     , cmapTableP
     , headTableP
@@ -128,6 +132,7 @@ import Prelude hiding (repeat)
 data DumpError
     = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
     | DumpRequiredTableMissingError String
+    | DumpRequestedTableMissingError String
     deriving Eq
 
 instance Show DumpError
@@ -135,6 +140,8 @@ instance Show DumpError
     show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
     show (DumpRequiredTableMissingError tableName) =
         "Required table " <> tableName <> " is missing."
+    show (DumpRequestedTableMissingError tableName) =
+        "Requested table " <> tableName <> " is missing."
 
 data RequiredTables = RequiredTables
     { hheaTable :: HheaTable
@@ -785,53 +792,78 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
         = "(" <> justifyNumber 7 coordinateX <> ", "
         <> justifyNumber 7 coordinateY <> ")"
 
+dumpTable
+    :: String
+    -> ParseState
+    -> FontDirectory
+    -> Either DumpError Text.Builder.Builder
+dumpTable needle processedState FontDirectory{..}
+    | Just neededTable <- find ((needle ==) . Char8.unpack . getField @"tag") tableDirectory
+        = parseRequired processedState tableDirectory
+        >>= maybe (pure mempty) (first DumpParseError)
+        . dumpSubTable processedState neededTable
+    | otherwise = Left $ DumpRequestedTableMissingError needle
+
 dumpTables
-    :: Megaparsec.State ByteString Void
+    :: ParseState
     -> FontDirectory
     -> Either DumpError Text.Builder.Builder
 dumpTables processedState directory@FontDirectory{..}
-    = parseRequired >>= traverseDirectory
+    = parseRequired processedState tableDirectory >>= traverseDirectory
   where
     traverseDirectory parsedRequired =
         let initial = Right $ dumpOffsetTable directory
          in foldl' (go parsedRequired) initial tableDirectory
-    parseRequired = do
+    go _ (Left accumulator) _ = Left accumulator
-        requiredHhea <- findRequired "hhea" hheaTableP
+    go parsedRequired (Right accumulator) tableEntry
-        requiredHead@HeadTable{ indexToLocFormat } <-
+        = maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
-            findRequired "head" headTableP
+        $ dumpSubTable processedState tableEntry parsedRequired
-        requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
+    concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
-        pure $ RequiredTables
+        <$> builderDump
-            { hheaTable = requiredHhea
+
-            , headTable = requiredHead 
+parseRequired
-            , locaTable = requiredLoca
+    :: (Foldable t)
-            } 
+    => ParseState
+    -> t TableDirectory
+    -> Either DumpError RequiredTables
+parseRequired processedState tableDirectory = do
+    requiredHhea <- findRequired "hhea" hheaTableP
+    requiredHead@HeadTable{ indexToLocFormat } <-
+        findRequired "head" headTableP
+    requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
+    pure $ RequiredTables
+        { hheaTable = requiredHhea
+        , headTable = requiredHead 
+        , locaTable = requiredLoca
+        } 
+  where
     findRequired tableName parser = 
         let missingError = Left $ DumpRequiredTableMissingError tableName
             parseFound tableEntry = parseTable tableEntry parser processedState
          in maybe missingError (first DumpParseError . parseFound)
             $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory
-    go _ (Left accumulator) _ = Left accumulator
+
-    go parsedRequired (Right accumulator) tableEntry
+dumpSubTable
-        = maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
+    :: ParseState
-        $ dumpSubTable parsedRequired tableEntry
+    -> TableDirectory
-    concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
+    -> RequiredTables
-        <$> builderDump
+    -> Maybe (Either ParseErrorBundle Text.Builder.Builder)
-    dumpSubTable RequiredTables{..} tableEntry =
+dumpSubTable processedState tableEntry RequiredTables{..} =
-        case getField @"tag" tableEntry of
+    case getField @"tag" tableEntry of
-            "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
+        "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
-            "head" -> Just $ Right $ dumpHead headTable
+        "head" -> Just $ Right $ dumpHead headTable
-            "hhea" -> Just $ Right $ dumpHhea hheaTable
+        "hhea" -> Just $ Right $ dumpHhea hheaTable
-            "hmtx" -> Just $ dumpHmtx
+        "hmtx" -> Just $ dumpHmtx
-                <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
+            <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
-            "loca" -> Just $ Right $ dumpLoca locaTable
+        "loca" -> Just $ Right $ dumpLoca locaTable
-            "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
+        "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
-            "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
+        "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
-            "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
+        "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
-            "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
+        "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
-            "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
+        "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
-            "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState
+        "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState
-            "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState
+        "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState
-            _ -> Nothing
+        _ -> Nothing
 
 dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder
 dumpTrueType ttfContents fontFile =

lib/Graphics/Fountainhead/Metrics.hs

@@ -3,27 +3,66 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Graphics.Fountainhead.Metrics
-    ( FontMetrics(..)
+    ( FontBBox(..)
-    , afmFontMetrics
+    , FontDescriptor(..)
+    , Number
+    , FontDescriptorFlag(..)
     ) where
 
-import qualified Data.Text.Lazy.Builder as Text.Builder
+import Data.Text (Text)
-import Data.Version (Version(..), showVersion)
-import Graphics.Fountainhead.Type (newlineBuilder)
 
-newtype FontMetrics = FontMetrics
+type Number = Double
-    { version :: Version
+
+data FontDescriptorFlag
+    = FixedPitch
+    | Serif
+    | Symbolic
+    | Script
+    | Nonsymbolic
+    | Italic
+    | AllCap
+    | SmallCap
+    | ForceBold
+    deriving (Eq, Show)
+
+instance Enum FontDescriptorFlag
+  where
+    toEnum 1 = FixedPitch
+    toEnum 2 = Serif
+    toEnum 3 = Symbolic
+    toEnum 4 = Script
+    toEnum 6 = Nonsymbolic
+    toEnum 7 = Italic
+    toEnum 17 = AllCap
+    toEnum 18 = SmallCap
+    toEnum 19 = ForceBold
+    toEnum _ = error "Font description flag is not supported."
+    fromEnum FixedPitch = 1
+    fromEnum Serif = 2
+    fromEnum Symbolic = 3
+    fromEnum Script = 4
+    fromEnum Nonsymbolic = 6
+    fromEnum Italic = 7
+    fromEnum AllCap = 17
+    fromEnum SmallCap = 18
+    fromEnum ForceBold = 19
+
+data FontBBox = FontBBox Number Number Number Number
+    deriving (Eq, Show)
+
+data FontDescriptor = FontDescriptor
+    { fontName :: Text
+    , flags :: [FontDescriptorFlag]
+    , fullName :: Text
+    , familyName :: Text
+    , weight :: Text
+    , fontBBox :: FontBBox
+    , version :: Text
+    , notice :: Text
+    , encodingScheme :: Text
+    , isFixedPitch :: Bool
+    , ascender :: Number
+    , descender :: Number
     } deriving (Eq, Show)
-
-afmKeyString :: Text.Builder.Builder -> String -> Text.Builder.Builder
-afmKeyString key value = key <> Text.Builder.singleton '\t'
-    <> Text.Builder.fromString value <> newlineBuilder
-
-afmFontMetrics :: FontMetrics -> Text.Builder.Builder
-afmFontMetrics FontMetrics{..}
-    = afmKeyString "StartFontMetrics" (showVersion version)
-    <> afmKeyString "Comment" "Generated by Fountainhead"
-    <> "EndFontMetrics" <> newlineBuilder

lib/Graphics/Fountainhead/Parser.hs

@@ -13,6 +13,7 @@
 module Graphics.Fountainhead.Parser
     ( Parser
     , ParseErrorBundle
+    , ParseState
     , cmapTableP
     , cvTableP
     , f2Dot14P
@@ -154,6 +155,7 @@ import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary
 
 type Parser = Megaparsec.Parsec Void ByteString
 type ParseErrorBundle = Megaparsec.ParseErrorBundle ByteString Void
+type ParseState = Megaparsec.State ByteString Void
 
 -- * Font directory
 
@@ -953,7 +955,7 @@ fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be
 parseTable
     :: TableDirectory
     -> Parser a
-    -> Megaparsec.State ByteString Void
+    -> ParseState
     -> Either ParseErrorBundle a
 parseTable TableDirectory{ offset, length = length' } parser state = snd
     $ Megaparsec.runParser' parser 

src/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 module Main
     ( main
     ) where
@@ -5,49 +6,49 @@ module Main
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.IO as Text.Lazy
 import Graphics.Fountainhead (dumpFontFile)
-import System.Exit (exitWith)
-import GHC.IO.Exception (ExitCode(..))
 import Options.Applicative
-    ( Parser
+    ( ParserInfo(..)
-    , ParserInfo(..)
     , (<**>)
     , argument
-    , command
     , execParser
+    , header
+    , help
     , helper
     , info
+    , long
     , fullDesc
     , metavar
+    , optional
     , progDesc
+    , short
     , str
-    , subparser
+    , strOption
     )
 
-data Operation
+data Options = Options
-    = Dump
+    { tableName :: Maybe String
-    | Afm
+    , fontFile :: FilePath
-    deriving (Eq, Show)
+    } deriving (Eq, Show)
-
-data Options = Options Operation FilePath
-    deriving (Eq, Show)
 
 operationOptions :: ParserInfo Options
-operationOptions = info (options <**> helper) fullDesc
+operationOptions = info (options <**> helper)
+    $ fullDesc
+    <> progDesc "Dumping the contents of a TrueType Font file."
+    <> header "fountainhead - font parser"
   where
     options = Options
-        <$> commands
+        <$> tableNameArgument
         <*> argument str (metavar "FONTFILE")
-    commands = subparser
+    tableNameArgument = optional $ strOption
-        $ command "dump" (info (pure Dump) (progDesc "Dumping the contents of a TrueType Font file."))
+        $ long "table"
-        <> command "afm" (info (pure Afm) (progDesc "Generating Adobe Font Metrics files for TrueType fonts."))
+        <> short 't'
+        <> metavar "tablename"
+        <> help "Dump only the specified table. Otherwise dump all tables"
 
 main :: IO ()
 main = execParser operationOptions >>= handleArguments
   where
-    handleArguments (Options Dump fontFile)
+    handleArguments Options{..}
         = putStrLn ("Dumping File:" <> fontFile <> "\n\n")
-        >> dumpFontFile fontFile
+        >> dumpFontFile fontFile tableName
         >>= either print (Text.Lazy.putStrLn . Text.Builder.toLazyText)
-    handleArguments (Options Afm _)
-        = putStrLn "The program expects exactly one argument, the font file path."
-        >> exitWith (ExitFailure 2)