Add missing license headers

.gitignore

@@ -1,4 +1,2 @@
 /dist-newstyle/
 /dist/
-
-/fonts/

CHANGELOG.md

@@ -1,3 +1,9 @@
-# Revision history for fountainhead
+# Changelog
+All notable changes to this project will be documented in this file.
+
+The format is based on
+[Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
 ## Unreleased

README.md

@@ -0,0 +1,51 @@
+# TrueType font parser
+
+Fountainhead is a TrueType and OpenType font parser. Its main
+purpose is to extract information from the fonts to help to
+embed these fonts into PDF documents. It also supports dumping
+font information to the screen.
+
+There is also an executable to dump fonts.
+
+## Installation
+
+Add the library as dependency to your project.
+Alternatively build an executable with:
+
+```sh
+cabal build
+```
+
+The binary can be run with:
+
+```sh
+cabal run fountainhead -- myfont.ttf
+```
+
+or installed locally and executed just as:
+
+```sh
+fountainhead myfont.ttf
+```
+
+This command will output the contents of the font in a format similar to
+ttfdump from TeXLive.
+
+See
+
+```sh
+fountainhead --help
+```
+
+for help.
+
+## Usage
+
+TrueType and OpenType fonts consist of a sequence of tables and various
+informations about the font are encoded in these tables. There are both
+required and optional tables. The first table is a font directory and it
+describes the overall structure of the font, what tables it contains and at what
+offset other tables can be found.
+
+This library doesn't parse the whole font at once. The font directory has to be
+parsed first and can be used then to parse further tables as needed.

README.txt

@@ -1,6 +0,0 @@
-# TrueType font parser.
-
-An experiment to create a TrueType and OpenType font parser and encoder
-that can be used to embed fonts in PDF.
-
-This project is currently only a draft.

app/Main.hs

@@ -1,37 +0,0 @@
-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 System.Exit (exitWith)
-import GHC.IO.Exception (ExitCode(..))
-
-fontMain :: FilePath -> IO ()
-fontMain fontFile = do
-    putStrLn ("Dumping File:" <> fontFile <> "\n\n")
-
-    (processedState, initialResult) <- parseFontDirectoryFromFile 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."
-
-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)

fountainhead.cabal

@@ -1,4 +1,4 @@
-cabal-version: 2.4
+cabal-version: 3.4
 name: fountainhead
 version: 0.1.0.0
 
@@ -12,35 +12,37 @@ author: Eugen Wissner
 license-files: LICENSE
 license: MPL-2.0
 
-copyright: (c) 2023 Eugen Wissner
+copyright: (c) 2025 Eugen Wissner
 category: Graphics
 
 extra-source-files:
   CHANGELOG.md
-  README.txt
+  README.md
 
 common dependencies
   build-depends:
-    bytestring ^>= 0.11.0,
-    text ^>= 2.0,
-    zlib ^>= 0.6.3
-  default-language: Haskell2010
+    base >= 4.16 && < 5,
+    bytestring ^>= 0.12.0,
+    text ^>= 2.1,
+    zlib ^>= 0.7.0
+  default-language: GHC2024
 
 library
   import: dependencies
   exposed-modules:
     Graphics.Fountainhead
+    Graphics.Fountainhead.Compression
     Graphics.Fountainhead.Dumper
+    Graphics.Fountainhead.Metrics
     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,
-    transformers ^>= 0.5,
+    containers ^>= 0.7,
+    megaparsec ^>= 9.7,
+    time ^>= 1.14,
+    transformers ^>= 0.6,
     vector ^>= 0.13.0
   ghc-options: -Wall
 
@@ -53,13 +55,27 @@ executable fountainhead
     DuplicateRecordFields
     ExplicitForAll
   build-depends:
-    base,
     containers,
+    fountainhead,
+    megaparsec,
+    optparse-applicative ^>= 0.18.1,
     parser-combinators,
     vector,
     transformers,
-    time,
-    megaparsec,
-    fountainhead
-  hs-source-dirs: app
+    time
+  hs-source-dirs: src
   ghc-options: -Wall
+
+test-suite fountainhead-test
+  import: dependencies
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs: test
+  other-modules:
+    Graphics.Fountainhead.MetricsSpec
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+    fountainhead,
+    hspec >= 2.9 && < 3
+  build-tool-depends:
+    hspec-discover:hspec-discover

lib/Graphics/Fountainhead.hs

@@ -0,0 +1,36 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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
+    ( dumpFontFile
+    , parseFontDirectoryFromFile
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.Void (Void)
+import Graphics.Fountainhead.Dumper (dumpTable, dumpTables, DumpError(..))
+import Graphics.Fountainhead.Parser (ParseErrorBundle, parseFontDirectory)
+import Graphics.Fountainhead.TrueType (FontDirectory(..))
+import Text.Megaparsec (State(..))
+import System.IO (IOMode(..), withBinaryFile)
+import Data.Bifunctor (Bifunctor(..))
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import Graphics.Fountainhead.Compression (hDecompress)
+
+-- | Does initial parsing of the font at the given path and returns the font
+-- directory and parsing state that can be used to parse other tables in the
+-- font.
+parseFontDirectoryFromFile :: FilePath
+    -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
+parseFontDirectoryFromFile fontFile = withBinaryFile fontFile ReadMode
+    $ fmap (parseFontDirectory fontFile) . hDecompress
+
+-- | Dumps the contents of the font in the file. If the table name is given,
+-- dumps only this one table.
+dumpFontFile :: FilePath -> Maybe String -> IO (Either DumpError Text.Builder.Builder)
+dumpFontFile fontFile tableName = do
+    let dumpRequest = maybe dumpTables dumpTable tableName
+    (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
+    pure $ first DumpParseError initialResult >>= dumpRequest processedState

lib/Graphics/Fountainhead/Compression.hs

@@ -0,0 +1,31 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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/. -}
+
+-- | 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

@@ -14,6 +14,8 @@
 module Graphics.Fountainhead.Dumper
     ( DumpError(..)
     , dumpCmap
+    , dumpGASP
+    , dumpGlyf
     , dumpHead
     , dumpHmtx
     , dumpHhea
@@ -22,14 +24,12 @@ module Graphics.Fountainhead.Dumper
     , dumpMaxp
     , dumpOs2
     , dumpPost
+    , dumpTable
     , dumpTables
-    , dumpTrueType
     , dumpOffsetTable
     ) where
 
-import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Char8 as Char8
 import Data.Int (Int64, Int16)
 import Data.Word (Word8, Word16, Word32)
 import qualified Data.IntMap as IntMap
@@ -38,16 +38,19 @@ import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import qualified Data.Text.Lazy.Builder.RealFloat as Text.Builder
 import Data.Vector (Vector)
 import qualified Data.Vector as Vector
-import Data.Void
 import GHC.Records (HasField(..))
 import Graphics.Fountainhead.TrueType
     ( CmapTable(..)
+    , CompoundGlyphDefinition(..)
+    , ComponentGlyphPartDescription(..)
     , FontDirectory(..)
     , FontDirectionHint(..)
     , GASPRange(..)
     , GASPTable(..)
+    , GlyphArgument(..)
     , HeadTable(..)
     , HheaTable(..)
     , HmtxTable(..)
@@ -61,6 +64,7 @@ import Graphics.Fountainhead.TrueType
     , CmapSubtable(..)
     , CmapFormat4Table(..)
     , FontStyle(..)
+    , GlyphArgument(..)
     , GlyphCoordinate(..)
     , GlyphDefinition(..)
     , GlyphDescription(..)
@@ -83,11 +87,16 @@ import Graphics.Fountainhead.TrueType
     , Panose(..)
     , SimpleGlyphDefinition(..)
     , CVTable(..)
-    , OutlineFlag (..)
+    , OutlineFlag(..)
+    , ComponentGlyphFlags(..)
+    , GlyphTransformationOption(..)
+    , findTableByTag
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
-    ( fontDirectoryP
+    ( ParseErrorBundle
+    , ParseState
+    , Parser
     , parseTable
     , cmapTableP
     , headTableP
@@ -102,9 +111,14 @@ import Graphics.Fountainhead.Parser
     , cvTableP
     , glyfTableP
     )
-import Graphics.Fountainhead.Type (Fixed32(..), succIntegral, ttfEpoch)
-import Data.Foldable (Foldable(..), find)
-import Data.Maybe (fromMaybe)
+import Graphics.Fountainhead.Type
+    ( Fixed32(..)
+    , succIntegral
+    , ttfEpoch
+    , fixed2Double
+    )
+import Data.Foldable (Foldable(..))
+import Data.Maybe (fromMaybe, catMaybes)
 import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
 import Data.Bits (Bits(..), (.>>.))
 import Data.Bifunctor (Bifunctor(first))
@@ -112,8 +126,18 @@ import Data.List (intersperse)
 import Prelude hiding (repeat)
 
 data DumpError
-    = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
+    = DumpParseError ParseErrorBundle
     | DumpRequiredTableMissingError String
+    | DumpRequestedTableMissingError String
+    deriving Eq
+
+instance Show DumpError
+  where
+    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
@@ -121,6 +145,9 @@ data RequiredTables = RequiredTables
     , locaTable :: LocaTable
     } deriving (Eq, Show)
 
+newlineBuilder :: Text.Builder.Builder
+newlineBuilder = Text.Builder.singleton '\n'
+
 paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
 paddedHexadecimal = ("0x" <>)
     . Text.Builder.fromLazyText
@@ -140,9 +167,6 @@ justifyNumber count = Text.Builder.fromLazyText
     . Text.Builder.toLazyText
     . Text.Builder.decimal
 
-newlineBuilder :: Text.Builder.Builder
-newlineBuilder = Text.Builder.singleton '\n'
-
 dumpCaption :: String -> Text.Builder.Builder
 dumpCaption headline = Text.Builder.fromString headline
     <> newlineBuilder
@@ -175,7 +199,7 @@ dumpFixed32 :: Fixed32 -> Text.Builder.Builder
 dumpFixed32 (Fixed32 word)
     = Text.Builder.decimal (shiftR word 16)
     <> Text.Builder.singleton '.'
-    <> Text.Builder.decimal (word .&. 0xff00)
+    <> Text.Builder.decimal (word .&. 0xffff)
 
 dumpHmtx :: HmtxTable -> Text.Builder.Builder
 dumpHmtx HmtxTable{..} =
@@ -268,7 +292,7 @@ longDateTime localTime = Text.Builder.fromLazyText
 dumpCVTable :: CVTable -> Text.Builder.Builder
 dumpCVTable (CVTable cvTable) = dumpCaption "'cvt ' Table - Control Value Table"
     <> "Size = " <> Text.Builder.decimal (tableSize * 2)
-    <> " bytes, " <> Text.Builder.decimal tableSize <> " entries\n"
+    <> " bytes, " <> Text.Builder.decimal tableSize <> " entries" <> newlineBuilder
     <> foldMap (uncurry go) (zip [0..] cvTable)
   where
     tableSize = Prelude.length cvTable
@@ -412,7 +436,7 @@ dumpPost :: PostTable -> Text.Builder.Builder
 dumpPost PostTable{ postHeader = PostHeader{..}, postSubtable }
     = dumpCaption "'post' Table - PostScript" <> newlineBuilder
     <> "         'post' format:          " <> dumpFixed32 format <> newlineBuilder
-    <> "         italicAngle:            " <> dumpFixed32 format <> newlineBuilder
+    <> "         italicAngle:            " <> dumpFixed32 italicAngle <> newlineBuilder
     <> "         underlinePosition:      " <> Text.Builder.decimal underlinePosition <> newlineBuilder
     <> "         underlineThichness:     " <> Text.Builder.decimal underlineThickness <> newlineBuilder
     <> "         isFixedPitch:           " <> dNumber isFixedPitch <> newlineBuilder
@@ -670,7 +694,69 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
         <> "         Coordinates" <> newlineBuilder
         <> "         -----------" <> newlineBuilder
         <> fst (Vector.ifoldl' foldCoordinate mempty coordinates)
-    dumpGlyphDefinition _ = "" -- TODO
+    dumpGlyphDefinition (CompoundGlyph CompoundGlyphDefinition{..})
+        = foldMap (dumpCompoundGlyph $ Vector.length components) (Vector.indexed components)
+        <> newlineBuilder <> "         Length of Instructions: "
+        <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
+    dumpCompoundGlyph :: Int -> (Int, ComponentGlyphPartDescription) -> Text.Builder.Builder
+    dumpCompoundGlyph componentsLength (componentIndex, description) =
+        let moreComponents = succ componentIndex < componentsLength
+            compoundFlags = dumpCompoundFlags moreComponents description
+            ComponentGlyphPartDescription{..} = description
+         in "         " <> Text.Builder.decimal componentIndex
+            <> ": Flags:       0x" <> compoundFlags <> newlineBuilder
+            <> "            Glyf Index:  " <> Text.Builder.decimal glyphIndex <> newlineBuilder
+            <> "            X" <> dumpArgument argument1 <> newlineBuilder
+            <> "            Y" <> dumpArgument argument2 <> newlineBuilder
+            <> dumpTransformationOption transformationOption
+            <> "            Others:      " <> dumpOtherFlags flags <> newlineBuilder
+            <> newlineBuilder -- TODO
+    dumpTransformationOption GlyphNoScale = ""
+    dumpTransformationOption (GlyphScale scale) =
+        "            X,Y Scale:   " <> Text.Builder.realFloat (fixed2Double scale) <> newlineBuilder
+    dumpTransformationOption (GlyphXyScale xScale yScale)
+        = "            X Scale:     " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder
+        <> "            Y Scale:     " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder
+    dumpTransformationOption (Glyph2By2Scale xScale scale01 scale10 yScale)
+        = "            X Scale:     " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder
+        <> "            X,Y Scale:   " <> Text.Builder.realFloat (fixed2Double scale01) <> newlineBuilder
+        <> "            Y,X Scale:   " <> Text.Builder.realFloat (fixed2Double scale10) <> newlineBuilder
+        <> "            Y Scale:     " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder
+    dumpOtherFlags ComponentGlyphFlags{..} =
+        let roundXyToGridText = if roundXyToGrid then "Round X,Y to Grid   " else "                    "
+            useMyMetricsText = if useMyMetrics then "Use My Metrics   " else "                 "
+            overlapCompoundText = if overlapCompound then "Overlap      " else "             "
+         in roundXyToGridText <> overlapCompoundText <> useMyMetricsText
+    dumpCompoundFlags :: Bool -> ComponentGlyphPartDescription -> Text.Builder.Builder
+    dumpCompoundFlags moreComponents ComponentGlyphPartDescription{..} =
+        let setBits = glyphArgumentBits argument1
+                <> componentFlagBits flags
+                <> transformationOptionBits transformationOption
+            setBits' = if moreComponents then 5 : setBits else setBits
+         in Text.Builder.hexadecimal
+            $ foldr (flip setBit) (zeroBits :: Word16) setBits'
+    dumpArgument (GlyphInt8Argument argument) =
+        " BOffset:   " <> Text.Builder.decimal argument
+    dumpArgument (GlyphInt16Argument argument) =
+        " WOffset:   " <> Text.Builder.decimal argument
+    dumpArgument (GlyphWord8Argument argument) =
+        " BPoint:    " <> Text.Builder.decimal argument
+    dumpArgument (GlyphWord16Argument argument) =
+        " WPoint:    " <> Text.Builder.decimal argument
+    glyphArgumentBits (GlyphInt16Argument _) = [0, 1]
+    glyphArgumentBits (GlyphWord16Argument _) = [0]
+    glyphArgumentBits (GlyphInt8Argument _) = [1]
+    glyphArgumentBits (GlyphWord8Argument _) = []
+    componentFlagBits ComponentGlyphFlags{..} = catMaybes
+        [ if roundXyToGrid then Just 2 else Nothing
+        , if weHaveInstructions then Just 8 else Nothing
+        , if useMyMetrics then Just 9 else Nothing
+        , if overlapCompound then Just 10 else Nothing
+        ]
+    transformationOptionBits GlyphScale{} = [3]
+    transformationOptionBits GlyphXyScale{} = [6]
+    transformationOptionBits Glyph2By2Scale{} = [7]
+    transformationOptionBits GlyphNoScale = []
     dumpFlag lineValue coordinateIndex
         = "         " <> justifyNumber 2 coordinateIndex <> lineValue
     foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int)
@@ -705,17 +791,37 @@ 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 <- findTableByTag needle fontDirectory
+        = parseRequired processedState fontDirectory
+        >>= 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 directory >>= traverseDirectory
   where
     traverseDirectory parsedRequired =
         let initial = Right $ dumpOffsetTable directory
          in foldl' (go parsedRequired) initial tableDirectory
-    parseRequired = do
+    go _ (Left accumulator) _ = Left accumulator
+    go parsedRequired (Right accumulator) tableEntry
+        = maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
+        $ dumpSubTable processedState tableEntry parsedRequired
+    concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
+        <$> builderDump
+
+parseRequired :: ParseState -> FontDirectory -> Either DumpError RequiredTables
+parseRequired processedState fontDirectory = do
     requiredHhea <- findRequired "hhea" hheaTableP
     requiredHead@HeadTable{ indexToLocFormat } <-
         findRequired "head" headTableP
@@ -725,18 +831,20 @@ dumpTables processedState directory@FontDirectory{..}
         , headTable = requiredHead 
         , locaTable = requiredLoca
         } 
+  where
+    findRequired :: String -> Parser a -> Either DumpError a
     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
-        = maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
-        $ dumpSubTable parsedRequired tableEntry
-    concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
-        <$> builderDump
-    dumpSubTable RequiredTables{..} tableEntry =
+            $ findTableByTag tableName fontDirectory
+
+dumpSubTable
+    :: ParseState
+    -> TableDirectory
+    -> RequiredTables
+    -> Maybe (Either ParseErrorBundle Text.Builder.Builder)
+dumpSubTable processedState tableEntry RequiredTables{..} =
     case getField @"tag" tableEntry of
         "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
         "head" -> Just $ Right $ dumpHead headTable
@@ -752,21 +860,3 @@ dumpTables processedState directory@FontDirectory{..}
         "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState
         "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState
         _ -> Nothing
-
-dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder
-dumpTrueType ttfContents fontFile =
-    let initialState = Megaparsec.State
-            { stateInput = ttfContents
-            , stateOffset = 0
-            , statePosState = Megaparsec.PosState
-                { pstateInput = ttfContents
-                , pstateOffset = 0
-                , pstateSourcePos = Megaparsec.initialPos fontFile
-                , pstateTabWidth = Megaparsec.defaultTabWidth
-                , pstateLinePrefix = ""
-                }
-            , stateParseErrors = []
-            }
-        (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState 
-
-     in first DumpParseError initialResult >>= dumpTables processedState

lib/Graphics/Fountainhead/Metrics.hs

@@ -0,0 +1,230 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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/. -}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Graphics.Fountainhead.Metrics
+    ( FontBBox(..)
+    , FontDescriptor(..)
+    , MetricsError(..)
+    , Number
+    , FontDescriptorFlag(..)
+    , collectMetrics
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.List (findIndex)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+import Graphics.Fountainhead.TrueType
+    ( BSerifStyle(..)
+    , FontDirectory(..)
+    , HeadTable(..)
+    , HheaTable(..)
+    , HmtxTable(..)
+    , LongHorMetric(..)
+    , NameRecord(..)
+    , NameTable(..)
+    , Os2BaseFields(..)
+    , Os2Version4Fields(..)
+    , Os2Version5Fields(..)
+    , Os2Table(..)
+    , Panose(..)
+    , PostHeader(..)
+    , PostTable(..)
+    , findTableByTag
+    , pattern Os2Version4CommonFields
+    )
+import Graphics.Fountainhead.Parser
+    ( Parser
+    , ParseErrorBundle
+    , ParseState
+    , nameTableP
+    , parseFontDirectory
+    , parseTable
+    , headTableP
+    , hheaTableP
+    , hmtxTableP
+    , os2TableP
+    , postTableP
+    )
+import qualified Text.Megaparsec as Megaparsec
+import Data.Bifunctor (Bifunctor(..))
+import Data.Int (Int16)
+import Data.Word (Word16)
+import GHC.Records (HasField(..))
+
+type Number = Float
+
+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]
+    , stemV :: Number
+    , missingWidth :: Number
+    , fontBBox :: FontBBox
+    , italicAngle :: Number
+    , capHeight :: Number
+    , ascender :: Number
+    , descender :: Number
+    } deriving (Eq, Show)
+
+data MetricsError
+    = MetricsParseError ParseErrorBundle
+    | MetricsRequiredTableMissingError String
+    | MetricsNameRecordNotFound Word16
+    | UnsupportedOs2VersionError
+    deriving Eq
+
+instance Show MetricsError
+  where
+    show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
+    show (MetricsRequiredTableMissingError tableName) =
+        "Required table " <> tableName <> " is missing."
+    show (MetricsNameRecordNotFound nameId) =
+        "Name record with ID " <> show nameId <> " was not found."
+    show UnsupportedOs2VersionError =
+        "OS/2 version 1 does not contain cap height."
+
+collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
+collectMetrics fontFile ttfContents =
+    case parseFontDirectory fontFile ttfContents of
+        (_processedState, Left initialResult) -> Left
+            $ MetricsParseError initialResult
+        (processedState, Right initialResult) -> do
+            let parseForMetrics' :: String -> Parser a -> Either MetricsError a
+                parseForMetrics' = parseForMetrics processedState initialResult
+
+            NameTable{ nameRecord, variable } <- parseForMetrics' "name" nameTableP
+            psNameIndex <- maybeMetricsError (MetricsNameRecordNotFound 6)
+                $ findIndex ((6 ==) . getField @"nameID") nameRecord
+
+            headTable@HeadTable{ unitsPerEm } <- parseForMetrics' "head" headTableP
+            let scale = (1000.0 :: Float) / fromIntegral unitsPerEm
+
+            HheaTable{ ascent, descent, numOfLongHorMetrics } <-
+                parseForMetrics' "hhea" hheaTableP
+            PostTable{ postHeader } <- parseForMetrics' "post" postTableP
+
+            (capHeight, os2BaseFields) <- getCapHeight processedState initialResult
+            let Os2BaseFields{ usWeightClass, panose } = os2BaseFields
+
+            HmtxTable{ hMetrics } <- parseForMetrics' "hmtx"
+                $ hmtxTableP numOfLongHorMetrics
+
+            let fixedPitchFlag = if getField @"isFixedPitch" postHeader > 0 then Just FixedPitch else Nothing
+                isSerifFlag = if isSerif $ getField @"bSerifStyle" panose then Just Serif else Nothing
+
+            pure $ FontDescriptor
+                { fontName = variableText nameRecord variable psNameIndex
+                , flags = []
+                , stemV = calculateStemV $ fromIntegral usWeightClass
+                , missingWidth = fromIntegral $ scalePs scale
+                    $ getField @"advanceWidth" $ NonEmpty.head hMetrics
+                , fontBBox =  calculateBoundingBox scale headTable
+                , italicAngle = realToFrac $ getField @"italicAngle" postHeader
+                , capHeight = fromIntegral $ scalePs scale capHeight
+                , ascender = fromIntegral $ scalePs scale ascent
+                , descender = fromIntegral $ scalePs scale descent
+                }
+  where
+    calculateStemV weightClass = 10 + 220 * (weightClass - 50) / 900
+    getCapHeight processedState initialResult = do
+        os2Table <- parseForMetrics processedState initialResult "OS/2" os2TableP
+        case os2Table of
+            Os2Version4CommonFields os2BaseFields Os2Version4Fields{ sCapHeight } ->
+                Right (sCapHeight, os2BaseFields)
+            Os2Version5 os2BaseFields _ Os2Version5Fields{ sCapHeight } ->
+                Right (sCapHeight, os2BaseFields)
+            _ -> Left UnsupportedOs2VersionError
+    calculateBoundingBox scale HeadTable{ xMin, xMax, yMin, yMax } =
+        let xMin' = fromIntegral $ scalePs scale xMin
+            yMin' = fromIntegral $ scalePs scale yMin
+            xMax' = fromIntegral $ scalePs scale xMax
+            yMax' = fromIntegral $ scalePs scale yMax
+         in FontBBox xMin' yMin' xMax' yMax'
+    scalePs :: Integral a => Float -> a -> Int16
+    scalePs scale value = truncate $ fromIntegral value * scale
+    variableText records variables recordIndex =
+        let NameRecord{ platformID } = records !! recordIndex
+            variable = variables !! recordIndex
+         in if platformID == 1
+            then Text.decodeUtf8 variable
+            else Text.decodeUtf16BE variable
+
+parseForMetrics
+    :: forall a
+    . ParseState
+    -> FontDirectory
+    -> String
+    -> Parser a
+    -> Either MetricsError a
+parseForMetrics processedState fontDirectory tableName tableParser =
+    let foundTable = findTableByTag tableName fontDirectory
+        missingError = MetricsRequiredTableMissingError tableName
+        parseTable' rawTable = parseTable rawTable tableParser processedState
+     in maybeMetricsError missingError foundTable
+        >>= first MetricsParseError . parseTable'
+
+maybeMetricsError :: forall a. MetricsError -> Maybe a -> Either MetricsError a
+maybeMetricsError metricsError Nothing = Left metricsError
+maybeMetricsError _ (Just result) = Right result
+
+isSerif :: BSerifStyle -> Bool
+isSerif AnySerifStyle = False
+isSerif NoFitSerifStyle = False
+isSerif CoveSerifStyle = True
+isSerif ObtuseCoveSerifStyle = True
+isSerif SquareCoveSerifStyle = True
+isSerif ObtuseSquareCoveSerifStyle = True
+isSerif SquareSerifStyle = True
+isSerif ThinSerifStyle = True
+isSerif BoneSerifStyle = True
+isSerif ExaggeratedSerifStyle =True
+isSerif TriangleSerifStyle = True
+isSerif NormalSansSerifStyle = False
+isSerif ObtuseSansSerifStyle = False
+isSerif PerpSansSerifStyle = False
+isSerif FlaredSerifStyle = True
+isSerif RoundedSerifStyle = True

lib/Graphics/Fountainhead/Parser.hs

@@ -13,6 +13,7 @@
 module Graphics.Fountainhead.Parser
     ( Parser
     , ParseErrorBundle
+    , ParseState
     , cmapTableP
     , cvTableP
     , f2Dot14P
@@ -32,6 +33,7 @@ module Graphics.Fountainhead.Parser
     , nameTableP
     , os2TableP
     , panoseP
+    , parseFontDirectory
     , parseTable
     , pascalStringP
     , postTableP
@@ -154,6 +156,30 @@ 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
+
+-- | Does initial parsing and returns the font directory and parsing state
+-- that can be used to parse other tables in the font.
+--
+-- Font file name can be empty.
+parseFontDirectory
+    :: FilePath
+    -> ByteString
+    -> (ParseState, Either ParseErrorBundle FontDirectory)
+parseFontDirectory fontFile ttfContents =
+    let initialState = Megaparsec.State
+            { stateInput = ttfContents
+            , stateOffset = 0
+            , statePosState = Megaparsec.PosState
+                { pstateInput = ttfContents
+                , pstateOffset = 0
+                , pstateSourcePos = Megaparsec.initialPos fontFile
+                , pstateTabWidth = Megaparsec.defaultTabWidth
+                , pstateLinePrefix = ""
+                }
+            , stateParseErrors = []
+            }
+     in Megaparsec.runParser' fontDirectoryP initialState 
 
 -- * Font directory
 
@@ -524,6 +550,8 @@ componentGlyphPartDescriptionP accumulator = do
     -- MORE_COMPONENTS.
     if testBit flags' 5 then componentGlyphPartDescriptionP updated else pure updated
 
+-- | Arguments are: WE_HAVE_A_SCALE, WE_HAVE_AN_X_AND_Y_SCALE and
+-- WE_HAVE_A_TWO_BY_TWO.
 transformationOptionP :: Bool -> Bool -> Bool -> Parser GlyphTransformationOption
 transformationOptionP True _ _ = GlyphScale <$> f2Dot14P <?> "scale"
 transformationOptionP _ True _ = GlyphXyScale
@@ -538,6 +566,7 @@ transformationOptionP _ _ True = Glyph2By2Scale
     <?> "2 by 2 transformation"
 transformationOptionP _ _ _ = pure GlyphNoScale
 
+-- | Arguments are: ARG_1_AND_2_ARE_WORDS and ARGS_ARE_XY_VALUES.
 glyphArgumentP :: Bool -> Bool -> Parser GlyphArgument
 glyphArgumentP True True = GlyphInt16Argument
     <$> Megaparsec.Binary.int16be
@@ -950,7 +979,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 

lib/Graphics/Fountainhead/TrueType.hs

@@ -2,8 +2,12 @@
    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/. -}
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Types representing a TrueType font.
 module Graphics.Fountainhead.TrueType
@@ -81,11 +85,14 @@ module Graphics.Fountainhead.TrueType
     , UVSMapping(..)
     , UnicodeValueRange(..)
     , VariationSelectorMap
+    , findTableByTag
     , unLocaTable
     , nameStringOffset
+    , pattern Os2Version4CommonFields
     ) where
 
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as Char8
 import Data.Int (Int8, Int16)
 import Data.IntMap (IntMap)
 import Data.List.NonEmpty (NonEmpty(..))
@@ -93,6 +100,8 @@ import Data.Time (LocalTime(..))
 import Data.Vector (Vector)
 import Data.Word (Word8, Word16, Word32)
 import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), FWord, UFWord)
+import GHC.Records (HasField(..))
+import Data.Foldable (find)
 
 -- * Font directory
 
@@ -101,6 +110,10 @@ data FontDirectory = FontDirectory
     , tableDirectory :: [TableDirectory]
     } deriving (Eq, Show)
 
+findTableByTag :: String -> FontDirectory -> Maybe TableDirectory
+findTableByTag needle = find ((needle ==) . Char8.unpack . getField @"tag")
+    . getField @"tableDirectory"
+
 data OffsetSubtable = OffsetSubtable
     { scalerType :: Word32
     , numTables :: Int
@@ -263,7 +276,10 @@ data PostHeader = PostHeader
     , italicAngle :: Fixed32 -- ^ Italic angle in degrees
     , underlinePosition :: Int16 -- ^ Underline position
     , underlineThickness :: Int16 -- ^ Underline thickness
-    , isFixedPitch :: Word32 -- ^ Font is monospaced; set to 1 if the font is monospaced and 0 otherwise (N.B., to maintain compatibility with older versions of the TrueType spec, accept any non-zero value as meaning that the font is monospaced)
+    -- | Font is monospaced; set to 1 if the font is monospaced and 0 otherwise
+    -- (N.B., to maintain compatibility with older versions of the TrueType
+    -- spec, accept any non-zero value as meaning that the font is monospaced)
+    , isFixedPitch :: Word32
     , minMemType42 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 42 font
     , maxMemType42 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 42 font
     , minMemType1 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 1 font
@@ -536,6 +552,21 @@ data Os2Table
     | Os2Version5 Os2BaseFields Os2MicrosoftFields Os2Version5Fields
     deriving (Eq, Show)
 
+pattern Os2Version4CommonFields :: Os2BaseFields -> Os2Version4Fields -> Os2Table
+pattern Os2Version4CommonFields baseFields versionFields <-
+    (os2Version4CommonFields -> Just (baseFields, versionFields))
+
+{-# COMPLETE Os2Version4CommonFields, Os2Version0, Os2Version1, Os2Version5 #-}
+
+os2Version4CommonFields :: Os2Table -> Maybe (Os2BaseFields, Os2Version4Fields)
+os2Version4CommonFields = \case
+    Os2Version0{} -> Nothing
+    Os2Version1{} -> Nothing
+    Os2Version2 baseFields _ versionFields -> Just (baseFields, versionFields)
+    Os2Version3 baseFields _ versionFields -> Just (baseFields, versionFields)
+    Os2Version4 baseFields _ versionFields -> Just (baseFields, versionFields)
+    Os2Version5{} -> Nothing
+
 data Os2Version1Fields = Os2Version1Fields
     { ulCodePageRange1 :: Word32
     , ulCodePageRange2 :: Word32

lib/Graphics/Fountainhead/Type.hs

@@ -0,0 +1,67 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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/. -}
+
+-- | Generic font types.
+module Graphics.Fountainhead.Type
+    ( F2Dot14(..)
+    , Fixed32(..)
+    , FWord
+    , UFWord
+    , fixed2Double
+    , succIntegral
+    , ttfEpoch
+    ) where
+
+import Data.Bits ((.>>.), (.&.))
+import Data.Int (Int16, Int32)
+import Data.Word (Word16, Word32)
+import Data.Time (Day(..))
+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
+import Data.Fixed (HasResolution(..))
+
+newtype Fixed32 = Fixed32 Word32
+    deriving (Eq, Show)
+
+instance Num Fixed32
+  where
+    (Fixed32 x) + (Fixed32 y) = Fixed32 $ x + y
+    (Fixed32 x) - (Fixed32 y) = Fixed32 $ x - y
+    (Fixed32 x) * (Fixed32 y) = Fixed32 $ div (x * y) 65536
+    abs (Fixed32 x) = Fixed32 $ fromIntegral $ abs (fromIntegral x :: Int32)
+    signum (Fixed32 x)
+        | x == 0 = Fixed32 0
+        | (fromIntegral x :: Int32) < 0 = Fixed32 0xffff0000
+        | otherwise = Fixed32 0x10000
+    fromInteger x = Fixed32 $ fromInteger $ x * 65536
+
+instance Ord Fixed32
+  where
+    compare (Fixed32 x) (Fixed32 y) =
+        compare (fromIntegral x :: Int32) (fromIntegral y)
+
+instance Real Fixed32
+  where
+    toRational (Fixed32 x) = toRational (fromIntegral x :: Int32) / 65536.0
+
+instance HasResolution Fixed32
+  where
+    resolution = const 65536
+
+newtype F2Dot14 = F2Dot14 Int16
+    deriving (Eq, Show)
+
+type FWord = Int16
+type UFWord = Word16
+
+ttfEpoch :: Day
+ttfEpoch = fromOrdinalDate 1904 1
+
+succIntegral :: Integral a => a -> Int
+succIntegral = succ . fromIntegral
+
+fixed2Double :: F2Dot14 -> Double
+fixed2Double (F2Dot14 fixed) =
+    let mantissa = realToFrac (fixed .>>. 14)
+        fraction = realToFrac (fixed .&. 0x3fff) / 16384.0
+     in mantissa + fraction

src/Graphics/Fountainhead.hs

@@ -1,50 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   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/. -}
-
-module Graphics.Fountainhead
-    ( 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.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)
-
-parseFontDirectoryFromFile :: String
-    -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
-parseFontDirectoryFromFile fontFile =
-    withBinaryFile fontFile ReadMode withFontHandle
-  where
-    withFontHandle fontHandle = doParsing
-        <$> readFontContents fontHandle
-    doParsing ttfContents =
-        let initialState = Megaparsec.State
-                { stateInput = ttfContents
-                , stateOffset = 0
-                , statePosState = Megaparsec.PosState
-                    { pstateInput = ttfContents
-                    , pstateOffset = 0
-                    , pstateSourcePos = Megaparsec.initialPos fontFile
-                    , pstateTabWidth = Megaparsec.defaultTabWidth
-                    , pstateLinePrefix = ""
-                    }
-                , 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

src/Graphics/Fountainhead/Type.hs

@@ -1,33 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   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/. -}
-
--- | Generic font types.
-module Graphics.Fountainhead.Type
-    ( F2Dot14(..)
-    , Fixed32(..)
-    , FWord
-    , UFWord
-    , succIntegral
-    , ttfEpoch
-    ) where
-
-import Data.Int (Int16)
-import Data.Word (Word16, Word32)
-import Data.Time (Day(..))
-import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
-
-newtype Fixed32 = Fixed32 Word32
-    deriving (Eq, Show)
-
-newtype F2Dot14 = F2Dot14 Int16
-    deriving (Eq, Show)
-
-type FWord = Int16
-type UFWord = Word16
-
-ttfEpoch :: Day
-ttfEpoch = fromOrdinalDate 1904 1
-
-succIntegral :: Integral a => a -> Int
-succIntegral = succ . fromIntegral

src/Main.hs

@@ -0,0 +1,58 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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/. -}
+
+{-# LANGUAGE RecordWildCards #-}
+module Main
+    ( main
+    ) where
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy.IO as Text.Lazy
+import Graphics.Fountainhead (dumpFontFile)
+import Options.Applicative
+    ( ParserInfo(..)
+    , (<**>)
+    , argument
+    , execParser
+    , header
+    , help
+    , helper
+    , info
+    , long
+    , fullDesc
+    , metavar
+    , optional
+    , progDesc
+    , short
+    , str
+    , strOption
+    )
+
+data Options = Options
+    { tableName :: Maybe String
+    , fontFile :: FilePath
+    } deriving (Eq, Show)
+
+operationOptions :: ParserInfo Options
+operationOptions = info (options <**> helper)
+    $ fullDesc
+    <> progDesc "Dumping the contents of a TrueType Font file."
+    <> header "fountainhead - font parser"
+  where
+    options = Options
+        <$> tableNameArgument
+        <*> argument str (metavar "FONTFILE")
+    tableNameArgument = optional $ strOption
+        $ long "table"
+        <> short 't'
+        <> metavar "tablename"
+        <> help "Dump only the specified table. Otherwise dump all tables"
+
+main :: IO ()
+main = execParser operationOptions >>= handleArguments
+  where
+    handleArguments Options{..}
+        = putStrLn ("Dumping File:" <> fontFile <> "\n\n")
+        >> dumpFontFile fontFile tableName
+        >>= either print (Text.Lazy.putStrLn . Text.Builder.toLazyText)

test/Graphics/Fountainhead/MetricsSpec.hs

@@ -0,0 +1,32 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Graphics.Fountainhead.MetricsSpec
+    ( spec
+    ) where
+
+import Graphics.Fountainhead.Metrics
+import Test.Hspec (Spec, describe, it, shouldBe)
+import qualified Data.ByteString as ByteString
+
+spec :: Spec
+spec =
+    describe "collectMetrics" $
+        it "collects information from the name table" $ do
+            let fontPath = "./fonts/OpenSans-Bold.ttf"
+                expected = FontDescriptor
+                    { fontName = "OpenSans−Bold"
+                    , flags = [] -- 4
+                    , ascender = 1068
+                    , descender = -292
+                    , fontBBox =  FontBBox (-548) (-271) 1201 1047
+                    , italicAngle = 0
+                    , capHeight = 714
+                    , stemV = 105
+                    , missingWidth = 600
+                    }
+            openSansBoldItalic <- ByteString.readFile fontPath
+            collectMetrics fontPath openSansBoldItalic `shouldBe` Right expected

test/Spec.hs

@@ -0,0 +1,5 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   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/. -}
+
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}