Add missing license headers

… than coordinates if the repeated value is given.

.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,56 +0,0 @@
-module Main
-    ( main
-    ) where
-
-import Control.Monad (foldM_)
-import Data.Int (Int64)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Char8 as Char8
-import Data.ByteString (ByteString)
-import qualified Text.Megaparsec as Megaparsec
-import Data.Foldable (find)
-import qualified Data.Text.Lazy.Builder as Text.Builder
-import qualified Data.Text.Lazy.Builder.Int as Text.Builder
-import qualified Data.Text.Lazy as Text.Lazy
-import qualified Data.Text.Lazy.IO as Text.Lazy
-import qualified Data.Text.Encoding as Text
-import GHC.Records (HasField(..))
-import Graphics.Fountainhead.Dumper (DumpError(..), dumpTrueType)
--- TODO: kern table since format 1.
--- For details on subtable format see examples in TrueType reference.
-import Graphics.Fountainhead.Parser
-    ( fontDirectoryP
-    , os2TableP
-    , parseTable
-    , shortLocaTableP
-    )
-import Graphics.Fountainhead.TrueType
-    ( FontDirectory(..)
-    , OffsetSubtable(..)
-    , TableDirectory(..)
-    )
-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"
-
-    ttfContents <- ByteString.readFile fontFile
-    
-    case dumpTrueType ttfContents fontFile 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,34 +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:
-    text ^>= 2.0
+    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.PDF
     Graphics.Fountainhead.Type
     Graphics.Fountainhead.TrueType
-  hs-source-dirs:
+  hs-source-dirs: lib
-    src
   build-depends:
-    base >= 4.16 && < 5,
+    containers ^>= 0.7,
-    bytestring ^>= 0.11.0,
+    megaparsec ^>= 9.7,
-    containers ^>= 0.6.5,
+    time ^>= 1.14,
-    megaparsec ^>= 9.3,
+    transformers ^>= 0.6,
-    time ^>= 1.12,
-    transformers ^>= 0.5,
     vector ^>= 0.13.0
   ghc-options: -Wall
 
@@ -52,14 +55,27 @@ executable fountainhead
     DuplicateRecordFields
     ExplicitForAll
   build-depends:
-    base,
-    bytestring,
     containers,
+    fountainhead,
+    megaparsec,
+    optparse-applicative ^>= 0.18.1,
     parser-combinators,
     vector,
     transformers,
-    time,
+    time
-    megaparsec,
+  hs-source-dirs: src
-    fountainhead
+  ghc-options: -Wall
-  hs-source-dirs: app
+
-  default-language: Haskell2010
+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,13 +24,12 @@ module Graphics.Fountainhead.Dumper
     , dumpMaxp
     , dumpOs2
     , dumpPost
-    , dumpTrueType
+    , dumpTable
+    , dumpTables
     , 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
@@ -37,14 +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(..)
@@ -58,6 +64,11 @@ import Graphics.Fountainhead.TrueType
     , CmapSubtable(..)
     , CmapFormat4Table(..)
     , FontStyle(..)
+    , GlyphArgument(..)
+    , GlyphCoordinate(..)
+    , GlyphDefinition(..)
+    , GlyphDescription(..)
+    , GlyfTable(..)
     , LongHorMetric(..)
     , LocaTable(..)
     , NameRecord (..)
@@ -74,39 +85,69 @@ import Graphics.Fountainhead.TrueType
     , Os2Version5Fields(..)
     , Os2Table(..)
     , Panose(..)
+    , SimpleGlyphDefinition(..)
     , CVTable(..)
+    , OutlineFlag(..)
+    , ComponentGlyphFlags(..)
+    , GlyphTransformationOption(..)
+    , findTableByTag
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
-    ( fontDirectoryP
+    ( ParseErrorBundle
+    , ParseState
+    , Parser
     , parseTable
     , cmapTableP
     , headTableP
     , hheaTableP
     , hmtxTableP
+    , gaspTableP
     , locaTableP
     , maxpTableP
     , nameTableP
     , os2TableP
-    , postTableP, cvTableP
+    , postTableP
+    , cvTableP
+    , glyfTableP
     )
-import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch)
+import Graphics.Fountainhead.Type
-import Data.Foldable (Foldable(..), find)
+    ( Fixed32(..)
-import Data.Maybe (fromMaybe)
+    , 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))
 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
     , headTable :: HeadTable
+    , 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
@@ -126,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
@@ -161,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{..} =
@@ -254,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
@@ -398,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
@@ -617,60 +655,208 @@ dumpMaxp (OpenMaxp OpenMaxpTable{..})
     <> "         'maxp' version:         " <> dumpFixed32 version <> newlineBuilder <> newlineBuilder
     <> "         numGlyphs:              " <> Text.Builder.decimal numGlyphs <> newlineBuilder
 
+dumpGASP :: GASPTable -> Text.Builder.Builder
+dumpGASP GASPTable{..} = dumpCaption "'gasp' Table - Grid-fitting And Scan-conversion Procedure"
+    <> "'gasp' version:  " <> Text.Builder.decimal version <> newlineBuilder
+    <> "numRanges:       " <> Text.Builder.decimal (Prelude.length gaspRange) <> newlineBuilder
+    <> foldMap dumpGASPRange (zip [0..] gaspRange)
+  where
+    dumpGASPRange :: (Int, GASPRange) -> Text.Builder.Builder
+    dumpGASPRange (index', GASPRange{..}) = newlineBuilder
+        <> "         gasp Range " <> Text.Builder.decimal index' <> newlineBuilder
+        <> "         rangeMaxPPEM:   " <> Text.Builder.decimal rangeMaxPPEM <> newlineBuilder
+        <> "         rangeGaspBehavior:      0x" <> halfPaddedHexadecimal rangeGaspBehavior <> newlineBuilder
+
+dumpGlyf :: GlyfTable -> Text.Builder.Builder
+dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
+    <> foldMap go (Vector.indexed glyfDescriptions)
+  where
+    go (glyphIndex, GlyphDescription{..})
+        = "Glyph " <> justifyNumber 6 glyphIndex <> Text.Builder.singleton '.' <> newlineBuilder
+        <> "         numberOfContours:       " <> Text.Builder.decimal numberOfContours <> newlineBuilder
+        <> "         xMin:                   " <> Text.Builder.decimal xMin <> newlineBuilder
+        <> "         yMin:                   " <> Text.Builder.decimal yMin <> newlineBuilder
+        <> "         xMax:                   " <> Text.Builder.decimal xMax <> newlineBuilder
+        <> "         yMax:                   " <> Text.Builder.decimal yMax <> newlineBuilder
+        <> newlineBuilder <> dumpGlyphDefinition definition <> newlineBuilder
+    dumpEndPoint (endPointIndex, endPoint)
+        = "         " <> justifyNumber 2 endPointIndex
+        <> ":  " <> Text.Builder.decimal endPoint <> newlineBuilder
+    dumpGlyphDefinition (SimpleGlyph SimpleGlyphDefinition{..})
+        = "         EndPoints" <> newlineBuilder
+        <> "         ---------" <> newlineBuilder
+        <> foldMap dumpEndPoint (Vector.indexed endPtsOfContours) <> newlineBuilder
+        <> "         Length of Instructions: "
+        <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
+        <> newlineBuilder <> "         Flags" <> newlineBuilder
+        <> "         -----" <> newlineBuilder
+        <> fst (Vector.foldl' foldFlag ("", 0) flags) <>  newlineBuilder
+        <> "         Coordinates" <> newlineBuilder
+        <> "         -----------" <> newlineBuilder
+        <> fst (Vector.ifoldl' foldCoordinate mempty coordinates)
+    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)
+    foldFlag (accumulator, coordinateIndex) OutlineFlag{..} =
+        let lineValue = ": "
+                <> (if thisYIsSame then "YDual  " else "       ")
+                <> (if thisXIsSame then "XDual  " else "       ")
+                <> (if repeat > 0 then "Repeat  " else "        ")
+                <> (if yShortVector then "Y-Short " else "        ")
+                <> (if xShortVector then "X-Short " else "        ")
+                <> (if onCurve then "On" else "Off")
+                <> newlineBuilder
+            repeatN = succIntegral repeat
+            repeatedLines = fold
+                $ Vector.cons accumulator
+                $ dumpFlag lineValue
+                <$> Vector.enumFromN coordinateIndex repeatN
+         in (repeatedLines, coordinateIndex + repeatN)
+    foldCoordinate
+        :: (Text.Builder.Builder, GlyphCoordinate)
+        -> Int
+        -> GlyphCoordinate
+        -> (Text.Builder.Builder, GlyphCoordinate)
+    foldCoordinate (accumulator, absCoordinate) coordinateIndex relCoordinate =
+        let nextAbs = relCoordinate <> absCoordinate
+            newLine = "         " <> justifyNumber 2 coordinateIndex
+                <> " Rel " <> dumpCoordinate relCoordinate
+                <> " -> Abs " <> dumpCoordinate nextAbs
+                <> newlineBuilder
+         in (accumulator <> newLine, nextAbs)
+    dumpCoordinate GlyphCoordinate{..}
+        = "(" <> 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 = RequiredTables
+    go _ (Left accumulator) _ = Left accumulator
-        <$> findRequired "hhea" hheaTableP
+    go parsedRequired (Right accumulator) tableEntry
-        <*> findRequired "head" headTableP
+        = 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
+    requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
+    pure $ RequiredTables
+        { hheaTable = requiredHhea
+        , 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
+            $ findTableByTag tableName fontDirectory
-    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
         "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
         "head" -> Just $ Right $ dumpHead headTable
         "hhea" -> Just $ Right $ dumpHhea hheaTable
         "hmtx" -> Just $ dumpHmtx
             <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
-            "loca" -> Just $ dumpLoca
+        "loca" -> Just $ Right $ dumpLoca locaTable
-                <$> parseTable tableEntry (locaTableP $ getField @"indexToLocFormat" headTable) processedState
         "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
         "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
         "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
         "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
         "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
+        "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

@@ -12,12 +12,15 @@
 -- | Font parser.
 module Graphics.Fountainhead.Parser
     ( Parser
+    , ParseErrorBundle
+    , ParseState
     , cmapTableP
     , cvTableP
     , f2Dot14P
     , fixedP
     , fontDirectoryP
     , fpgmTableP
+    , gaspTableP
     , glyfTableP
     , hdmxTableP
     , headTableP
@@ -30,6 +33,7 @@ module Graphics.Fountainhead.Parser
     , nameTableP
     , os2TableP
     , panoseP
+    , parseFontDirectory
     , parseTable
     , pascalStringP
     , postTableP
@@ -97,6 +101,8 @@ import Graphics.Fountainhead.TrueType
     , FontDirectionHint(..)
     , FontDirectory(..)
     , FontStyle(..)
+    , GASPRange(..)
+    , GASPTable(..)
     , GlyfTable(..)
     , GlyphArgument(..)
     , GlyphCoordinate(..)
@@ -138,12 +144,42 @@ import Graphics.Fountainhead.TrueType
     , VariationSelectorMap
     , unLocaTable
     )
-import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), ttfEpoch)
+import Graphics.Fountainhead.Type
+    ( F2Dot14(..)
+    , Fixed32(..)
+    , succIntegral
+    , ttfEpoch
+    )
 import Text.Megaparsec ((<?>))
 import qualified Text.Megaparsec as Megaparsec
 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
 
@@ -514,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
@@ -528,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
@@ -556,60 +595,62 @@ simpleGlyphDefinitionP numberOfContours' = do
     instructions' <- vectorNP instructionLength
             (Megaparsec.Binary.word8 <?> "simple glyph instruction")
     flags' <- flagsP numberOfPoints mempty <?> "flags"
-    xs <- Vector.foldM (coordinateP xFlagPair) mempty flags'
+    xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags'
-    ys <- Vector.foldM (coordinateP yFlagPair) mempty flags'
+    ys <- Vector.foldM (coordinatesP yFlagPair) mempty flags'
     pure $ SimpleGlyphDefinition
         { endPtsOfContours = endPtsOfContours'
         , instructions = instructions'
-        , coordinates = mkCoordinate <$> Vector.zip3 xs ys flags'
+        , flags = flags'
+        , coordinates = mkCoordinate <$> Vector.zip xs ys
         }
   where
-    mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve
+    mkCoordinate (x, y) = GlyphCoordinate x y
     xFlagPair :: OutlineFlag -> (Bool, Bool)
     xFlagPair OutlineFlag{ xShortVector, thisXIsSame } =
         (xShortVector, thisXIsSame)
     yFlagPair :: OutlineFlag -> (Bool, Bool)
     yFlagPair OutlineFlag{ yShortVector, thisYIsSame } =
         (yShortVector, thisYIsSame)
-    coordinateP
+    coordinateP :: Bool -> Bool -> Parser Int16
+    coordinateP True True = fromIntegral
+        <$> Megaparsec.Binary.word8
+        <?> "1 byte long positive coordinate"
+    coordinateP True False = negate . fromIntegral
+        <$> Megaparsec.Binary.word8
+        <?> "1 byte long negative coordinate"
+    coordinateP False False = Megaparsec.Binary.int16be
+        <?> "2 bytes long coordinate"
+    coordinateP False True = pure 0
+    coordinatesP
         :: (OutlineFlag -> (Bool, Bool))
         -> Vector Int16
         -> OutlineFlag
         -> Parser (Vector Int16)
-    coordinateP get accumulator first =
+    coordinatesP get accumulator first =
-        case get first of
+        let parser = uncurry coordinateP $ get first
-            (True, True) -> Vector.snoc accumulator . fromIntegral
+            repeatN = succIntegral $ getField @"repeat" first
-                <$> Megaparsec.Binary.word8
+         in (accumulator <>) <$> vectorNP repeatN parser
-                <?> "1 byte long positive coordinate"
-            (True, False)
-                -> Vector.snoc accumulator  . negate . fromIntegral
-                <$> Megaparsec.Binary.word8
-                <?> "1 byte long negative coordinate"
-            (False, False) -> Vector.snoc accumulator
-                <$> Megaparsec.Binary.int16be
-                <?> "2 bytes long coordinate"
-            (False, True) -> pure $ Vector.snoc accumulator 0
     flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag)
     flagsP remaining accumulator
         | remaining < 0 = pure accumulator
         | otherwise = do
             flag <- Megaparsec.Binary.word8 <?> "outline flags"
+            repeatN <- 
+                if testBit flag 3
+                then fromIntegral
+                    <$> Megaparsec.Binary.word8
+                    <?> "flag repeat count"
+                else pure 0
             let flag' = OutlineFlag
                     { onCurve = testBit flag 0
                     , xShortVector = testBit flag 1
                     , yShortVector = testBit flag 2
+                    , repeat = fromIntegral repeatN
                     , thisXIsSame = testBit flag 4
                     , thisYIsSame = testBit flag 5
                     }
-            repeatN <- 
+            flagsP (remaining - repeatN - 1)
-                if testBit flag 3
+                $ Vector.snoc accumulator flag'
-                then (1 +)
-                    . fromIntegral
-                    <$> Megaparsec.Binary.word8
-                    <?> "flag repeat count"
-                else pure 1
-            flagsP (remaining - repeatN)
-                $ accumulator <> Vector.replicate repeatN flag'
 
 glyfTableP :: LocaTable -> Parser GlyfTable
 glyfTableP locaTable
@@ -772,7 +813,7 @@ cmapFormat13TableP = cmapFormat12TableP
 
 cmapFormat12TableP :: Parser CmapFormat12Table
 cmapFormat12TableP = do
-    Megaparsec.takeP Nothing 6 -- Reserved and length.
+    void $ Megaparsec.takeP Nothing 6 -- Reserved and length.
     language' <- Megaparsec.Binary.word32be
     nGroups <- fromIntegral <$> Megaparsec.Binary.word32be
     groups' <- vectorNP nGroups cmapGroupP
@@ -784,7 +825,7 @@ cmapFormat12TableP = do
 
 cmapFormat10TableP :: Parser CmapFormat10Table
 cmapFormat10TableP = do
-    Megaparsec.takeP Nothing 2 -- Reserved.
+    void $ Megaparsec.takeP Nothing 2 -- Reserved.
     length' <- fromIntegral <$> Megaparsec.Binary.word32be
     language' <- Megaparsec.Binary.word32be
     startCharCode' <- Megaparsec.Binary.word32be
@@ -801,7 +842,7 @@ cmapFormat10TableP = do
 
 cmapFormat8TableP :: Parser CmapFormat8Table
 cmapFormat8TableP = do
-    Megaparsec.takeP Nothing 6 -- Reserved and length.
+    void $ Megaparsec.takeP Nothing 6 -- Reserved and length.
     language' <- Megaparsec.Binary.word32be
     is32' <- Megaparsec.takeP Nothing 65536
     nGroups <- fromIntegral <$> Megaparsec.Binary.word32be
@@ -821,7 +862,7 @@ cmapGroupP = CmapGroup
 
 cmapFormat6TableP :: Parser CmapFormat6Table
 cmapFormat6TableP = do
-    Megaparsec.Binary.word16be -- Length.
+    void Megaparsec.Binary.word16be -- Length.
     language' <- Megaparsec.Binary.word16be
     firstCode' <- Megaparsec.Binary.word16be
     entryCount' <- fromIntegral <$> Megaparsec.Binary.word16be
@@ -842,8 +883,7 @@ cmapFormat4TableP = do
     entrySelector' <- Megaparsec.Binary.word16be
     rangeShift' <- Megaparsec.Binary.word16be
     endCode' <- vectorNP segCount Megaparsec.Binary.word16be
-    rangeShift' <- Megaparsec.Binary.word16be
+    void $ Megaparsec.chunk $ ByteString.pack [0, 0] -- reservedPad 0.
-    -- reservedPad 0.
     startCode' <- vectorNP segCount Megaparsec.Binary.word16be
     idDelta' <- vectorNP segCount Megaparsec.Binary.word16be
     idRangeOffset' <- vectorNP segCount Megaparsec.Binary.word16be
@@ -867,7 +907,7 @@ cmapFormat2TableP = do
     length' <- fromIntegral <$> Megaparsec.Binary.word16be
     language' <- Megaparsec.Binary.word16be
     subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be
-    let maxIndex = succ $ fromIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys'
+    let maxIndex = succIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys'
     subHeaders' <- vectorNP maxIndex cmapFormat2SubheaderP
     let glyphIndexLength = div (length' - 518 - maxIndex * 8) 2
     glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be
@@ -939,8 +979,8 @@ fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be
 parseTable
     :: TableDirectory
     -> Parser a
-    -> Megaparsec.State ByteString Void
+    -> ParseState
-    -> Either (Megaparsec.ParseErrorBundle ByteString Void) a
+    -> Either ParseErrorBundle a
 parseTable TableDirectory{ offset, length = length' } parser state = snd
     $ Megaparsec.runParser' parser 
     $ state
@@ -1211,3 +1251,20 @@ bMidlineP
     <|> (Megaparsec.single 12 $> LowPointedMidline)
     <|> (Megaparsec.single 13 $> LowSerifedMidline)
     <?> "bMidline"
+
+-- * Grid-fitting And Scan-conversion Procedure.
+
+gaspTableP :: Parser GASPTable
+gaspTableP = do
+    version' <- Megaparsec.Binary.word16be
+    numberRanges <- fromIntegral <$> Megaparsec.Binary.word16be
+    parsedRanges <- Megaparsec.count numberRanges gaspRangeP
+    Megaparsec.eof
+    pure $ GASPTable
+        { version = version'
+        , gaspRange = parsedRanges
+        }
+  where
+    gaspRangeP = GASPRange
+        <$> Megaparsec.Binary.word16be
+        <*> Megaparsec.Binary.word16be

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
@@ -40,6 +44,8 @@ module Graphics.Fountainhead.TrueType
     , FontDirectionHint(..)
     , FontDirectory(..)
     , FontStyle(..)
+    , GASPRange(..)
+    , GASPTable(..)
     , GlyfTable(..)
     , GlyphArgument(..)
     , GlyphCoordinate(..)
@@ -71,6 +77,7 @@ module Graphics.Fountainhead.TrueType
     , PostSubtable(..)
     , PostTable(..)
     , PrepTable(..)
+    , RangeGaspBehavior(..)
     , SimpleGlyphDefinition(..)
     , TableDirectory(..)
     , TrueMaxpTable(..)
@@ -78,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(..))
@@ -90,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
 
@@ -98,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
@@ -260,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
@@ -338,6 +357,8 @@ data SimpleGlyphDefinition = SimpleGlyphDefinition
     { endPtsOfContours :: Vector Word16
     -- | Array of instructions for this glyph.
     , instructions :: Vector Word8
+    -- Array of flags.
+    , flags :: Vector OutlineFlag
     -- | Array of coordinates; the first is relative to (0,0), others are
     -- relative to previous point.
     , coordinates :: Vector GlyphCoordinate
@@ -363,9 +384,19 @@ data ComponentGlyphFlags = ComponentGlyphFlags
 data GlyphCoordinate = GlyphCoordinate
     { coordinateX :: Int16
     , coordinateY :: Int16
-    , onCurve :: Bool
     } deriving (Eq, Show)
 
+instance Semigroup GlyphCoordinate
+  where
+    lhs <> rhs =
+        let GlyphCoordinate{ coordinateX = lhX, coordinateY = lhY } = lhs
+            GlyphCoordinate{ coordinateX = rhX, coordinateY = rhY } = rhs
+         in GlyphCoordinate{ coordinateX = lhX + rhX, coordinateY = lhY + rhY }
+
+instance Monoid GlyphCoordinate
+  where
+    mempty = GlyphCoordinate 0 0
+
 data ComponentGlyphPartDescription = ComponentGlyphPartDescription
     { flags :: ComponentGlyphFlags
     , glyphIndex :: Word16
@@ -380,6 +411,7 @@ data OutlineFlag = OutlineFlag
     { onCurve :: Bool
     , xShortVector :: Bool
     , yShortVector :: Bool
+    , repeat :: Word8
     , thisXIsSame :: Bool
     , thisYIsSame :: Bool
     } deriving (Eq, Show)
@@ -387,8 +419,9 @@ data OutlineFlag = OutlineFlag
 newtype GlyfTable = GlyfTable (Vector GlyphDescription)
     deriving (Eq, Show)
 
--- * Character to glyph mapping table
+-- 'cmap' table
 
+-- | Character to glyph mapping table.
 data CmapTable = CmapTable
     { version :: Word16 -- ^ Version number is zero.
     -- | Encodings with an offset into subtables map.
@@ -519,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
@@ -1273,3 +1321,29 @@ data KernFormat2Table = KernFormat2Table
    , classTableHeader :: ClassTableHeader
    , values :: [Int16]
    } deriving (Eq, Show)
+
+-- * 'gasp' table
+
+-- | Grid-fitting And Scan-conversion Procedure.
+data GASPTable = GASPTable
+    { version :: Word16 -- ^ Version number (set to 0).
+    , gaspRange :: [GASPRange] -- ^ Sorted by ppem.
+    } deriving (Eq, Show)
+
+data GASPRange = GASPRange
+    { rangeMaxPPEM :: Word16 -- ^ Upper limit of range, in PPEM.
+    , rangeGaspBehavior :: Word16 -- ^ Flags describing desired rasterizer behavior.
+    } deriving (Eq, Show)
+
+data RangeGaspBehavior
+    = KGASPGridFit -- ^ Use gridfitting.
+    | KGASPDoGray -- ^ Use grayscale rendering.
+    deriving (Eq, Show)
+
+instance Enum RangeGaspBehavior
+  where
+    toEnum 1 = KGASPGridFit
+    toEnum 2 = KGASPDoGray
+    toEnum _ = error "Unknown range GASP behavior"
+    fromEnum KGASPGridFit = 1
+    fromEnum KGASPDoGray = 2

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/PDF.hs

@@ -1,316 +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/. -}
-
-{-# LANGUAGE EmptyDataDecls #-}
-
-module Graphics.Fountainhead.PDF
-    ( Dictionary(..)
-    , E5
-    , Header(..)
-    , Link(..)
-    , Name(..)
-    , Object(..)
-    , Sink
-    , TextString(..)
-    , Trailer(..)
-    , Type(..)
-    , UncoatedString(..)
-    , XRefSection(..)
-    , XRefEntry(..)
-    , arrayType
-    , headerToPdf
-    , dictionaryToPdf
-    , dictionaryType
-    , linkToPdf
-    , linkType
-    , nameToPdf
-    , nameType
-    , nextName
-    , objectToPdf
-    , sinkWithLength
-    , stringType
-    , textStringToPdf
-    , textType
-    , trailerToPdf
-    , typeToPdf
-    , uncoatedStringToPdf
-    , xrefEntryToPdf
-    , xrefSectionToPdf
-    , writeObject
-    ) where
-
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Trans.State (StateT, get, gets, put)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Builder as ByteString.Builder
-import qualified Data.ByteString.Builder as ByteString (Builder)
-import qualified Data.ByteString.Lazy as ByteString.Lazy
-import Data.Char (ord)
-import Data.Fixed (Fixed(..), HasResolution(..), showFixed)
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-
--- | The header in the first line of a PDF file contains a PDF version number
--- consisting of a major and a minor version.
-data Header = Header Int Int
-    deriving (Eq, Show)
-
--- | See t'Header'.
-headerToPdf :: Header -> ByteString.Builder
-headerToPdf (Header major minor)
-    = ByteString.Builder.string7 "%PDF-"
-    <> ByteString.Builder.intDec major
-    <> ByteString.Builder.char7 '.'
-    <> ByteString.Builder.intDec minor
-    <> ByteString.Builder.char7 '\n'
-
--- | A name object is an atomic symbol uniquely defined by a sequence of
--- characters.
-newtype Name = Name String
-    deriving (Eq, Show)
-
--- | See t'Name'.
-nameToPdf :: Name -> ByteString.Builder
-nameToPdf (Name name) = ByteString.Builder.char7 '/'
-    <> ByteString.Builder.string7 name
-
--- | A dictionary object is an associative table containing pairs of objects.
-newtype Dictionary = Dictionary (Vector (Name, Type))
-
--- | See t'Dictionary'.
-dictionaryToPdf :: Dictionary -> IO ByteString.Builder
-dictionaryToPdf (Dictionary valuePairs) = do
-    pairs <- traverse pairToPdf valuePairs
-    pure
-        $ ByteString.Builder.string7 "<<"
-        <> unwordBuilder pairs
-        <> ByteString.Builder.string7 ">>"
-  where
-    pairToPdf (name, value) = do
-        value' <- typeToPdf value
-        pure $ nameToPdf name <> ByteString.Builder.char7 ' ' <> value'
-
--- | Hexadecimal data.
-newtype UncoatedString = UncoatedString String
-    deriving (Eq, Show)
-
--- | See t'UncoatedString'.
-uncoatedStringToPdf :: UncoatedString -> ByteString.Builder
-uncoatedStringToPdf (UncoatedString uncoatedString)
-    = ByteString.Builder.char7 '<'
-    <> ByteString.Builder.string8 uncoatedString
-    <> ByteString.Builder.char7 '>'
-
--- | A sequence of literal characters.
-newtype TextString = TextString String
-    deriving (Eq, Show)
-
--- | See t'TextString'.
-textStringToPdf :: TextString -> ByteString.Builder
-textStringToPdf (TextString textString)
-    = ByteString.Builder.char7 '('
-    <> ByteString.Builder.stringUtf8 textString 
-    <> ByteString.Builder.char7 ')'
-
--- Resolution of 10^-5 = .001.
-data E5
-
-instance HasResolution E5
-  where
-    resolution _ = 100000
-
--- | Reference to an inderect object, consisting of the object name and
--- revision.
-data Link = Link Int Int
-    deriving (Eq, Show)
-
--- | See t'Link'.
-linkToPdf :: Link -> ByteString.Builder
-linkToPdf (Link name revision)
-    = ByteString.Builder.intDec name
-    <> ByteString.Builder.char7 ' '
-    <> ByteString.Builder.intDec revision
-    <> ByteString.Builder.string8 " R"
-
--- | Basic types of object.
-data Type
-    = DictionaryType Dictionary
-    | ArrayType (Vector Type)
-    | LinkType Link
-    | NameType Name
-    | IntegerType Int
-    | RealType (Fixed E5)
-    | StreamType Dictionary (IO ByteString)
-    | StringType UncoatedString
-    | TextType TextString
-    | NullType
-
--- | See t'Type'.
-typeToPdf :: Type -> IO ByteString.Builder
-typeToPdf (DictionaryType dictionary) = dictionaryToPdf dictionary
-typeToPdf (ArrayType values) = do
-    converted <- traverse typeToPdf values
-    pure
-        $ ByteString.Builder.char7 '['
-        <> unwordBuilder converted
-        <> ByteString.Builder.char7 ']'
-typeToPdf (LinkType link) = pure $ linkToPdf link
-typeToPdf (NameType name) = pure $ nameToPdf name
-typeToPdf (IntegerType pdfInteger) = pure $ ByteString.Builder.intDec pdfInteger
-typeToPdf (StreamType dictionary producer) = do
-    streamContents <- producer
-    producedDictionary <- dictionaryToPdf dictionary
-    pure
-        $ producedDictionary
-        <> ByteString.Builder.string8 "\nstream\n"
-        <> ByteString.Builder.byteString streamContents
-        <> ByteString.Builder.string8 "\nendstream"
-typeToPdf (StringType string) = pure $ uncoatedStringToPdf string
-typeToPdf (TextType text) = pure $ textStringToPdf text
-typeToPdf (RealType realType) =
-    pure $ ByteString.Builder.string7 $ showFixed True realType
-typeToPdf NullType = pure $ ByteString.Builder.string7 "null"
-
--- | Object number, generation number and object contents.
-data Object = Object Int Int Type
-
--- | See t'Object'.
-objectToPdf :: Object -> IO ByteString.Builder
-objectToPdf (Object name revision type') = do
-    producedType <- typeToPdf type'
-    pure $ ByteString.Builder.intDec name
-        <> ByteString.Builder.char7 ' '
-        <> ByteString.Builder.intDec revision
-        <> ByteString.Builder.string7 " obj\n"
-        <> producedType
-        <> ByteString.Builder.string7 "\nendobj\n"
-
--- | Shortcut to create a t'Dictionary' type.
-dictionaryType :: [(Name, Type)] -> Type
-dictionaryType = DictionaryType . Dictionary . Vector.fromList
-
--- | Shortcut to create an t'Array' type.
-arrayType :: [Type] -> Type
-arrayType = ArrayType . Vector.fromList
-
--- | Shortcut to create a t'Name' type.
-nameType :: String -> Type
-nameType = NameType . Name
-
--- | Shortcut to create a t'UncoatedString' type.
-stringType :: String -> Type
-stringType = StringType . UncoatedString
-
--- | Shortcut to create a t'TextString' type.
-textType :: String -> Type
-textType = TextType . TextString
-
--- | Shortcut to create a t'Link' type.
-linkType :: Int -> Int -> Type
-linkType name revision = LinkType $ Link name revision
-
--- | Byte offset of an object in the file, generation number and whether this is
--- an in-use entry.
-data XRefEntry = XRefEntry Int Int Bool
-    deriving (Eq, Show)
-
--- | See t'XRefEntry'.
-xrefEntryToPdf :: XRefEntry -> ByteString.Builder
-xrefEntryToPdf (XRefEntry offset generation True)
-    = pad 10 offset
-    <> ByteString.Builder.char7 ' '
-    <> pad 5 generation
-    <> ByteString.Builder.string7 " n"
-xrefEntryToPdf (XRefEntry offset generation False)
-    = pad 10 offset
-    <> ByteString.Builder.char7 ' '
-    <> pad 5 generation
-    <> ByteString.Builder.string7 " f"
-
--- | Cross-reference table containing information about the indirect objects in
--- the file.
-newtype XRefSection = XRefSection
-    { unXRefSection :: Vector XRefEntry
-    } deriving (Eq, Show)
-
--- | See t'XRefSection'.
-xrefSectionToPdf :: XRefSection -> ByteString.Builder
-xrefSectionToPdf (XRefSection entries)
-    = ByteString.Builder.string7 "xref\n0 "
-    <> ByteString.Builder.intDec (length entries)
-    <> newline
-    <> Vector.foldMap (newline <>) (xrefEntryToPdf <$> entries)
-    <> newline
-
-instance Semigroup XRefSection
-  where
-    (XRefSection lhs) <> (XRefSection rhs) = XRefSection $ lhs <> rhs
-
-instance Monoid XRefSection
-  where
-    mempty = XRefSection mempty
-
--- | A trailer giving the location of the cross-reference table and of certain
--- special objects within the body of the file.
-data Trailer = Trailer Dictionary Int
-
--- | See t'Trailer'.
-trailerToPdf :: Trailer -> IO ByteString.Builder
-trailerToPdf (Trailer dictionary startxref) = do
-    producedDictionary <- dictionaryToPdf dictionary
-    pure $ ByteString.Builder.string7 "trailer "
-        <> producedDictionary
-        <> ByteString.Builder.string7 "\nstartxref\n"
-        <> ByteString.Builder.intDec startxref
-        <> ByteString.Builder.string7 "\n%%EOF\n"
-
-pad :: Int -> Int -> ByteString.Builder
-pad length' number =
-    let asString = ByteString.Builder.intDec number
-        numberLength = builderLength asString
-        padding = ByteString.Builder.byteString
-            $ ByteString.replicate (length' - numberLength) zero
-     in padding <> asString
-  where
-    zero = fromIntegral $ ord '0'
-    builderLength = fromIntegral
-        . ByteString.Lazy.length
-        . ByteString.Builder.toLazyByteString
-
-unwordBuilder :: Vector ByteString.Builder -> ByteString.Builder
-unwordBuilder = Vector.foldMap (ByteString.Builder.char7 ' ' <>)
-
-newline :: ByteString.Builder
-newline = ByteString.Builder.char7 '\n'
-
-type Sink = ByteString.Lazy.ByteString -> IO ()
-
--- | Creates a new object using the provided value, writes the object to the
--- sink, and returns a reference to that object.
---
--- For example if the passed value is a dictionary, the created object could be
--- @
--- 2 0 obj <<…>> endobj
--- @
--- where "2 0" identifies the object. The name (2) is generated using the state,
--- the revision is always 0.
-writeObject :: Sink -> Type -> StateT (Int, XRefSection) IO Link
-writeObject sink object = do
-    (previousLength, XRefSection refs) <- get
-    let objectName = length refs
-    objectContents <- liftIO $ objectToPdf $ Object objectName 0 object
-    writtenLength <- liftIO $ sinkWithLength sink objectContents
-    put (previousLength + writtenLength, XRefSection $ Vector.snoc refs (XRefEntry previousLength 0 True))
-    pure $ Link objectName 0
-
--- | Gets the name of the object which will be generated next.
-nextName :: StateT (Int, XRefSection) IO Int
-nextName = gets (length . unXRefSection . snd)
-
--- | Writes the data into the sink and returns the number of the written bytes.
-sinkWithLength :: Sink -> ByteString.Builder -> IO Int
-sinkWithLength sink data' =
-    let lazyData = ByteString.Builder.toLazyByteString data'
-     in sink lazyData >> pure (fromIntegral $ ByteString.Lazy.length lazyData)

src/Graphics/Fountainhead/Type.hs

@@ -1,29 +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
-    , 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

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 #-}