Add font compression

author: Eugen Wissner <belka@caraus.de> 2024-02-03 11:58:47 +0100
committer: Eugen Wissner <belka@caraus.de> 2024-02-03 11:58:47 +0100
commit: a34b46e1b553623d5dc385fc8e235df808fbadb2 (patch)
tree: 7035a9625532bf6f7f41962c4352ac2367d065f3 /lib
parent: 34d3ece99e438e5e81f4df6ca7a36de307e41b3e (diff)
download: fountainhead-a34b46e1b553623d5dc385fc8e235df808fbadb2.tar.gz
6 files changed, 3533 insertions, 0 deletions
diff --git a/lib/Graphics/Fountainhead.hs b/lib/Graphics/Fountainhead.hs
new file mode 100644
index 0000000..3852d51
--- /dev/null
+++ b/lib/Graphics/Fountainhead.hs
@@ -0,0 +1,49 @@
+{- 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 (dumpTables, DumpError(..))
+import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
+import Graphics.Fountainhead.TrueType (FontDirectory(..))
+import qualified Text.Megaparsec as Megaparsec
+import Text.Megaparsec (PosState(..), State(..))
+import System.IO (IOMode(..), withBinaryFile)
+import Data.Bifunctor (Bifunctor(..))
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import Graphics.Fountainhead.Compression (hDecompress)
+
+parseFontDirectoryFromFile :: FilePath
+    -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
+parseFontDirectoryFromFile fontFile =
+    withBinaryFile fontFile ReadMode withFontHandle
+  where
+    withFontHandle fontHandle = doParsing
+        <$> hDecompress 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 
+
+dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
+dumpFontFile fontFile = do
+    (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
+
+    pure $ first DumpParseError initialResult >>= dumpTables processedState
diff --git a/lib/Graphics/Fountainhead/Compression.hs b/lib/Graphics/Fountainhead/Compression.hs
new file mode 100644
index 0000000..c1a05fc
--- /dev/null
+++ b/lib/Graphics/Fountainhead/Compression.hs
@@ -0,0 +1,27 @@
+-- | Font compression and decompression.
+module Graphics.Fountainhead.Compression
+    ( compress
+    , hDecompress
+    ) where
+
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Codec.Compression.Zlib as Zlib
+import System.IO (Handle, SeekMode(..), hFileSize, hSeek)
+
+-- | Reads the font from a file handle decompressing it if needed.
+hDecompress :: Handle -> IO ByteString
+hDecompress fontHandle = do
+    firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2
+    hSeek fontHandle AbsoluteSeek 0
+    fileSize <- fromIntegral <$> hFileSize fontHandle
+    case firstBytes of
+        0x78 : [secondByte]
+            | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] ->
+                ByteString.Lazy.toStrict . Zlib.decompress
+                    <$> ByteString.Lazy.hGet fontHandle fileSize
+        _ -> ByteString.hGetContents fontHandle
+
+compress :: ByteString -> ByteString
+compress = ByteString.Lazy.toStrict . Zlib.compress . ByteString.Lazy.fromStrict
diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs
new file mode 100644
index 0000000..bbb17c2
--- /dev/null
+++ b/lib/Graphics/Fountainhead/Dumper.hs
@@ -0,0 +1,854 @@
+{- 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 PatternGuards #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Outputs information about a font as text.
+module Graphics.Fountainhead.Dumper
+    ( DumpError(..)
+    , dumpCmap
+    , dumpGlyf
+    , dumpHead
+    , dumpHmtx
+    , dumpHhea
+    , dumpLoca
+    , dumpName
+    , dumpMaxp
+    , dumpOs2
+    , dumpPost
+    , 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
+import qualified Data.Text as Text
+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(..)
+    , OffsetSubtable(..)
+    , PostHeader(..)
+    , PostSubtable(..)
+    , PostFormat2Table(..)
+    , PostTable(..)
+    , TableDirectory(..)
+    , CmapEncoding(..)
+    , CmapSubtable(..)
+    , CmapFormat4Table(..)
+    , FontStyle(..)
+    , GlyphArgument(..)
+    , GlyphCoordinate(..)
+    , GlyphDefinition(..)
+    , GlyphDescription(..)
+    , GlyfTable(..)
+    , LongHorMetric(..)
+    , LocaTable(..)
+    , NameRecord (..)
+    , NameTable(..)
+    , IndexToLocFormat(..)
+    , OpenMaxpTable(..)
+    , MaxpTable(..)
+    , TrueMaxpTable(..)
+    , nameStringOffset
+    , Os2BaseFields(..)
+    , Os2MicrosoftFields(..)
+    , Os2Version1Fields(..)
+    , Os2Version4Fields(..)
+    , Os2Version5Fields(..)
+    , Os2Table(..)
+    , Panose(..)
+    , SimpleGlyphDefinition(..)
+    , CVTable(..)
+    , OutlineFlag(..)
+    , ComponentGlyphFlags(..)
+    , GlyphTransformationOption(..)
+    )
+import qualified Text.Megaparsec as Megaparsec
+import Graphics.Fountainhead.Parser
+    ( fontDirectoryP
+    , parseTable
+    , cmapTableP
+    , headTableP
+    , hheaTableP
+    , hmtxTableP
+    , gaspTableP
+    , locaTableP
+    , maxpTableP
+    , nameTableP
+    , os2TableP
+    , postTableP
+    , cvTableP
+    , glyfTableP
+    )
+import Graphics.Fountainhead.Type
+    ( Fixed32(..)
+    , succIntegral
+    , ttfEpoch
+    , fixed2Double
+    )
+import Data.Foldable (Foldable(..), find)
+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)
+    | DumpRequiredTableMissingError String
+    deriving Eq
+
+instance Show DumpError
+  where
+    show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
+    show (DumpRequiredTableMissingError tableName) =
+        "Required table " <> tableName <> " is missing."
+
+data RequiredTables = RequiredTables
+    { hheaTable :: HheaTable
+    , headTable :: HeadTable
+    , locaTable :: LocaTable
+    } deriving (Eq, Show)
+
+paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
+paddedHexadecimal = ("0x" <>)
+    . Text.Builder.fromLazyText
+    . Text.Lazy.justifyRight 8 '0'
+    . Text.Builder.toLazyText
+    . Text.Builder.hexadecimal
+
+halfPaddedHexadecimal :: Integral a => a -> Text.Builder.Builder
+halfPaddedHexadecimal = Text.Builder.fromLazyText
+    . Text.Lazy.justifyRight 4 '0'
+    . Text.Builder.toLazyText
+    . Text.Builder.hexadecimal
+
+justifyNumber :: Integral a => Int64 -> a -> Text.Builder.Builder
+justifyNumber count = Text.Builder.fromLazyText
+    . Text.Lazy.justifyRight count ' '
+    . 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
+    <> Text.Builder.fromLazyText (Text.Lazy.replicate headlineLength "-")
+    <> newlineBuilder
+  where
+    headlineLength = fromIntegral $ Prelude.length headline
+
+dumpOffsetTable :: FontDirectory -> Text.Builder.Builder
+dumpOffsetTable directory
+    = dumpCaption "Offset Table"
+    <> "         sfnt version:           1.0\n         number of tables: "
+    <> Text.Builder.decimal (numTables $ offsetSubtable directory)
+    <> newlineBuilder
+    <> dumpOffsetSummary (tableDirectory directory)
+  where
+    dumpOffsetSummary = mconcat . fmap dumpOffsetRow . zip [0 :: Int ..]
+    dumpOffsetRow (index, table) = justifyNumber 4 index
+        <> ". '"
+        <> Text.Builder.fromText (Text.decodeASCII $ tag table)
+        <> "' - checksum = "
+        <> paddedHexadecimal (getField @"checkSum" table)
+        <> ", offset = "
+        <> paddedHexadecimal (getField @"offset" table)
+        <> ", len = "
+        <> justifyNumber 9 (getField @"length" table)
+        <> newlineBuilder
+
+dumpFixed32 :: Fixed32 -> Text.Builder.Builder
+dumpFixed32 (Fixed32 word)
+    = Text.Builder.decimal (shiftR word 16)
+    <> Text.Builder.singleton '.'
+    <> Text.Builder.decimal (word .&. 0xff00)
+
+dumpHmtx :: HmtxTable -> Text.Builder.Builder
+dumpHmtx HmtxTable{..} =
+    let caption = dumpCaption "'hmtx' Table - Horizontal Metrics"
+        lastAccumulator = foldl' dumpHMetric (0 :: Int, caption) hMetrics
+     in snd $ foldl' dumpLeftSideBear lastAccumulator leftSideBearing
+  where
+    dumpLeftSideBear (index, accumulator) leftSideBearing' =
+        let withNewLine = dumpIndex index <> ". LSbear: "
+                <> justifyNumber 4 leftSideBearing' <> newlineBuilder
+         in (succ index, accumulator <> withNewLine)
+    dumpHMetric (index, accumulator) metric =
+        let LongHorMetric{ leftSideBearing = leftSideBearing', ..} = metric
+            withNewLine = dumpIndex index <> ". advWid: "
+                <> justifyNumber 4 advanceWidth <> ",  LSBear: "
+                <> justifyNumber 4 leftSideBearing' <> newlineBuilder
+         in (succ index, accumulator <> withNewLine)
+    dumpIndex = justifyNumber 12
+
+dumpHhea :: HheaTable -> Text.Builder.Builder
+dumpHhea HheaTable{..}
+    = dumpCaption "'hhea' Table - Horizontal Header"
+    <> "         'hhea' version:         " <> dumpFixed32 version <> newlineBuilder
+    <> "         yAscender:              " <> Text.Builder.decimal ascent <> newlineBuilder
+    <> "         yDescender:             " <> Text.Builder.decimal descent <> newlineBuilder
+    <> "         yLineGap:               " <> Text.Builder.decimal lineGap <> newlineBuilder
+    <> "         advanceWidthMax:        " <> Text.Builder.decimal advanceWidthMax <> newlineBuilder
+    <> "         minLeftSideBearing:     " <> Text.Builder.decimal minLeftSideBearing <> newlineBuilder
+    <> "         minRightSideBearing:    " <> Text.Builder.decimal minRightSideBearing <> newlineBuilder
+    <> "         xMaxExtent:             " <> Text.Builder.decimal xMaxExtent <> newlineBuilder
+    <> "         caretSlopeRise:         " <> Text.Builder.decimal caretSlopeRise <> newlineBuilder
+    <> "         caretSlopeRun:          " <> Text.Builder.decimal caretSlopeRun <> newlineBuilder
+    <> "         reserved0:              0" <> newlineBuilder
+    <> "         reserved1:              0" <> newlineBuilder
+    <> "         reserved2:              0" <> newlineBuilder
+    <> "         reserved3:              0" <> newlineBuilder
+    <> "         reserved4:              0" <> newlineBuilder
+    <> "         metricDataFormat:       " <> Text.Builder.decimal metricDataFormat <> newlineBuilder
+    <> "         numberOfHMetrics:       " <> Text.Builder.decimal numOfLongHorMetrics <> newlineBuilder
+
+dumpHead :: HeadTable -> Text.Builder.Builder
+dumpHead HeadTable{..}
+    = dumpCaption "'head' Table - Font Header"
+    <> "         head version:           " <> dumpFixed32 version <> newlineBuilder
+    <> "         fontRevision:           " <> dumpFixed32 fontRevision <> newlineBuilder
+    <> "         checkSumAdjustment:     " <> paddedHexadecimal checkSumAdjustment <> newlineBuilder
+    <> "         magicNumber:            " <> paddedHexadecimal magicNumber <> newlineBuilder
+    <> "         flags:                  0x" <> halfPaddedHexadecimal flags <> newlineBuilder
+    <> "         unitsPerEm:             " <> Text.Builder.decimal unitsPerEm <> newlineBuilder
+    <> "         created:                " <> "0x" <> longDateTime created <> newlineBuilder
+    <> "         modified:               " <> "0x" <> longDateTime modified <> 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
+    <> "         macStyle bits:          " <> "0x" <> dumpFontStyle macStyle <> newlineBuilder
+    <> "         lowestRecPPEM           " <> Text.Builder.decimal lowestRecPPEM <> newlineBuilder
+    <> "         fontDirectionHint       " <> dumpFontDirectionHint fontDirectionHint <> newlineBuilder
+    <> "         indexToLocFormat        " <> dumpIndexToLocFormat indexToLocFormat <> newlineBuilder
+    <> "         glyphDataFormat         " <> Text.Builder.decimal glyphDataFormat <> newlineBuilder
+
+dumpIndexToLocFormat :: IndexToLocFormat -> Text.Builder.Builder
+dumpIndexToLocFormat ShortOffsetIndexToLocFormat = "0"
+dumpIndexToLocFormat LongOffsetIndexToLocFormat = "1"
+
+dumpFontDirectionHint :: FontDirectionHint -> Text.Builder.Builder
+dumpFontDirectionHint = \case
+    MixedDirectionalGlyphs -> "0"
+    StronglyLeftToRightGlyphs -> "1"
+    LeftToRightGlyphsWithNeutrals -> "2"
+    StronglyRightToLeftGlyphs -> "-1"
+    RightToLeftGlyphsWithNeutrals -> "-2"
+
+dumpFontStyle :: FontStyle -> Text.Builder.Builder
+dumpFontStyle FontStyle{..} = halfPaddedHexadecimal
+    $ foldr (go . fst) (zeroBits :: Int)
+    $ filter snd
+    $ zip [0..] [bold, italic, underline, outline, shadow, condensed, extended]
+  where
+    go bitNumber accumulator = setBit accumulator bitNumber
+
+longDateTime :: LocalTime -> Text.Builder.Builder
+longDateTime localTime = Text.Builder.fromLazyText
+    $ Text.Lazy.justifyRight 16 '0'
+    $ Text.Builder.toLazyText
+    $ Text.Builder.hexadecimal
+    $ (truncate :: NominalDiffTime -> Int)
+    $ diffLocalTime localTime (LocalTime ttfEpoch midnight)
+
+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"
+    <> foldMap (uncurry go) (zip [0..] cvTable)
+  where
+    tableSize = Prelude.length cvTable
+    go :: Int -> Int16 -> Text.Builder.Builder
+    go index' entry = justifyNumber 13 index' <> ".   "
+        <> Text.Builder.decimal entry <> newlineBuilder
+
+dumpOs2 :: Os2Table -> Text.Builder.Builder
+dumpOs2 = (dumpCaption "'OS/2' Table - OS/2 and Windows Metrics" <>) . go
+  where
+    go = \case
+        Os2Version0 baseFields msFields -> dumpBaseFields baseFields
+            <> maybe "" dumpMicrosoftFields msFields
+        Os2Version1 baseFields msFields extraFields -> dumpBaseFields baseFields
+            <> dumpMicrosoftFields msFields <> dumpVersion1Fields extraFields
+        Os2Version2 baseFields msFields extraFields -> dumpBaseFields baseFields
+            <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields
+        Os2Version3 baseFields msFields extraFields -> dumpBaseFields baseFields
+            <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields
+        Os2Version4 baseFields msFields extraFields -> dumpBaseFields baseFields
+            <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields
+        Os2Version5 baseFields msFields extraFields -> dumpBaseFields baseFields
+            <> dumpMicrosoftFields msFields <> dumpVersion5Fields extraFields
+    dumpVersion1Fields Os2Version1Fields{..}
+        = "         CodePage Range 1( Bits 0 - 31 ):        " <> paddedHexadecimal ulCodePageRange1 <> newlineBuilder
+        <> "         CodePage Range 2( Bits 32- 63 ):        " <> paddedHexadecimal ulCodePageRange2 <> newlineBuilder
+    dumpVersion4Fields Os2Version4Fields{..}
+        = dumpVersion1Fields (Os2Version1Fields ulCodePageRange1 ulCodePageRange2)
+        <> "         sxHeight:               " <> Text.Builder.decimal sxHeight <> newlineBuilder
+        <> "         sCapHeight:             " <> Text.Builder.decimal sCapHeight <> newlineBuilder
+        <> "         usDefaultChar:          0x" <> halfPaddedHexadecimal usDefaultChar <> newlineBuilder
+        <> "         usBreakChar:            0x" <> halfPaddedHexadecimal usBreakChar <> newlineBuilder
+        <> "         usMaxContext:           " <> Text.Builder.decimal usMaxContext <> newlineBuilder
+    dumpVersion5Fields Os2Version5Fields{..}
+        = dumpVersion1Fields (Os2Version1Fields ulCodePageRange1 ulCodePageRange2)
+        <> "         sxHeight:               " <> Text.Builder.decimal sxHeight <> newlineBuilder
+        <> "         sCapHeight:             " <> Text.Builder.decimal sCapHeight <> newlineBuilder
+        <> "         usDefaultChar:          0x" <> halfPaddedHexadecimal usDefaultChar <> newlineBuilder
+        <> "         usBreakChar:            0x" <> halfPaddedHexadecimal usBreakChar <> newlineBuilder
+        <> "         usMaxContext:           " <> Text.Builder.decimal usMaxContext <> newlineBuilder
+        <> "         usLowerOpticalPointSize:                 "
+        <> Text.Builder.decimal usLowerOpticalPointSize <> newlineBuilder
+        <> "         usUpperOpticalPointSize:                 "
+        <> Text.Builder.decimal usUpperOpticalPointSize <> newlineBuilder
+    dumpMicrosoftFields Os2MicrosoftFields{..}
+        = "         sTypoAscender:          " <> Text.Builder.decimal sTypoAscender <> newlineBuilder
+        <> "         sTypoDescender:         " <> Text.Builder.decimal sTypoDescender <> newlineBuilder
+        <> "         sTypoLineGap:           " <> Text.Builder.decimal sTypoLineGap <> newlineBuilder
+        <> "         usWinAscent:            " <> Text.Builder.decimal usWinAscent <> newlineBuilder
+        <> "         usWinDescent:           " <> Text.Builder.decimal usWinDescent <> newlineBuilder
+    dumpBaseFields Os2BaseFields{..}
+        = "         'OS/2' version:         " <> Text.Builder.decimal version <> newlineBuilder
+        <> "         xAvgCharWidth:          " <> Text.Builder.decimal xAvgCharWidth <> newlineBuilder
+        <> "         usWeightClass:          " <> weightClass usWeightClass <> newlineBuilder
+        <> "         usWidthClass:           " <> widthClass usWidthClass <> newlineBuilder
+        <> "         fsType:                 " <> Text.Builder.decimal fsType <> newlineBuilder
+        <> "         ySubscriptXSize:        " <> Text.Builder.decimal ySubscriptXSize <> newlineBuilder
+        <> "         ySubscriptYSize:        " <> Text.Builder.decimal ySubscriptYSize <> newlineBuilder
+        <> "         ySubscriptXOffset:      " <> Text.Builder.decimal ySubscriptXOffset <> newlineBuilder
+        <> "         ySubscriptYOffset:      " <> Text.Builder.decimal ySubscriptYOffset <> newlineBuilder
+        <> "         ySuperscriptXSize:      " <> Text.Builder.decimal ySuperscriptXSize <> newlineBuilder
+        <> "         ySuperscriptYSize:      " <> Text.Builder.decimal ySuperscriptYSize <> newlineBuilder
+        <> "         ySuperscriptXOffset:    " <> Text.Builder.decimal ySuperscriptXOffset <> newlineBuilder
+        <> "         ySuperscriptYOffset:    " <> Text.Builder.decimal ySuperscriptYOffset <> newlineBuilder
+        <> "         yStrikeoutSize:         " <> Text.Builder.decimal yStrikeoutSize <> newlineBuilder
+        <> "         yStrikeoutPosition:     " <> Text.Builder.decimal yStrikeoutPosition <> newlineBuilder
+        <> "         sFamilyClass:" <> familyClass sFamilyClass <> newlineBuilder
+        <> "         PANOSE:" <> newlineBuilder <> dumpPanose panose
+        <> fold (Vector.imap dumpUnicodeRange  ulUnicodeRange)
+        <> "         achVendID:              '" <> achVendID' achVendID <> "'\n"
+        <> "         fsSelection:            0x" <> fsSelection' fsSelection <> newlineBuilder
+        <> "         usFirstCharIndex:       0x" <> halfPaddedHexadecimal fsFirstCharIndex <> newlineBuilder
+        <> "         usLastCharIndex:        0x" <> halfPaddedHexadecimal fsLastCharIndex <> newlineBuilder
+    fsSelection' value =
+        let description = fold
+                [ if testBit value 0 then "Italic " else ""
+                , if testBit value 5 then "Bold " else ""
+                ]
+         in halfPaddedHexadecimal value <> "           '" <> description <> "'"
+    achVendID' = Text.Builder.fromText . Text.decodeLatin1 . ByteString.pack . fmap fromIntegral . toList
+    dumpUnicodeRange index value =
+        let bits = index * 32
+            parens = "( Bits " <> Text.Builder.decimal bits <> " - "
+                <> Text.Builder.decimal (bits + 31) <> " ):"
+         in "         Unicode Range: " <> Text.Builder.decimal (index + 1)
+            <> Text.Builder.fromLazyText (Text.Lazy.justifyLeft 25 ' ' (Text.Builder.toLazyText parens))
+            <> paddedHexadecimal value
+            <> newlineBuilder
+    dumpPanose Panose{..}
+        = "                 Family Kind:    " <> dumpPanoseField bFamilyType
+        <> "                 Serif Style:    " <> dumpPanoseField bSerifStyle
+        <> "                 Weight:         " <> dumpPanoseField bWeight
+        <> "                 Proportion:     " <> dumpPanoseField bProportion
+        <> "                 Contrast:       " <> dumpPanoseField bContrast
+        <> "                 Stroke:         " <> dumpPanoseField bStrokeVariation
+        <> "                 Arm Style:      " <> dumpPanoseField bArmStyle
+        <> "                 Lettreform:     " <> dumpPanoseField bLetterform
+        <> "                 Midline:        " <> dumpPanoseField bMidline
+        <> "                 X-height:       " <> dumpPanoseField bXHeight
+    dumpPanoseField field' =
+        let numericField = Text.Builder.fromLazyText
+                $ Text.Lazy.justifyLeft 8 ' '
+                $ Text.Builder.toLazyText
+                $ Text.Builder.decimal
+                $ fromEnum field'
+         in numericField
+            <> Text.Builder.singleton '\''
+            <> Text.Builder.fromString (show field')
+            <> Text.Builder.singleton '\''
+            <> newlineBuilder
+    familyClass value =
+        "   " <> Text.Builder.decimal (value .>>. 8) <> "       subclass = " <> Text.Builder.decimal (value .&. 0x00ff)
+    weightClass classValue
+        | Just wordValue <- fWeight classValue = Text.Builder.decimal classValue <> "     '" <> wordValue <> "'"
+        | otherwise = Text.Builder.decimal classValue
+    widthClass classValue
+        | Just wordValue <- fWidth classValue = Text.Builder.decimal classValue <> "       '" <> wordValue <> "'"
+        | otherwise = Text.Builder.decimal classValue
+    fWeight 100 = Just "Thin"
+    fWeight 200 = Just "Extra-light"
+    fWeight 300 = Just "Light"
+    fWeight 400 = Just "Normal"
+    fWeight 500 = Just "Medium"
+    fWeight 600 = Just "Semi-bold"
+    fWeight 700 = Just "Bold"
+    fWeight 800 = Just "Extra-bold"
+    fWeight 900 = Just "Black"
+    fWeight _ = Nothing
+    fWidth 1 = Just "Ultra-condensed"
+    fWidth 2 = Just "Extra-condensed"
+    fWidth 3 = Just "Condensed"
+    fWidth 4 = Just "Semi-condensed"
+    fWidth 5 = Just "Medium"
+    fWidth 6 = Just "Semi-expanded"
+    fWidth 7 = Just "Expanded"
+    fWidth 8 = Just "Extra-expanded"
+    fWidth 9 = Just "Ultra-expanded"
+    fWidth _ = Nothing
+
+dumpPost :: PostTable -> Text.Builder.Builder
+dumpPost PostTable{ postHeader = PostHeader{..}, postSubtable }
+    = dumpCaption "'post' Table - PostScript" <> newlineBuilder
+    <> "         'post' format:          " <> dumpFixed32 format <> newlineBuilder
+    <> "         italicAngle:            " <> dumpFixed32 format <> newlineBuilder
+    <> "         underlinePosition:      " <> Text.Builder.decimal underlinePosition <> newlineBuilder
+    <> "         underlineThichness:     " <> Text.Builder.decimal underlineThickness <> newlineBuilder
+    <> "         isFixedPitch:           " <> dNumber isFixedPitch <> newlineBuilder
+    <> "         minMemType42:           " <> dNumber minMemType42 <> newlineBuilder
+    <> "         maxMemType42:           " <> dNumber maxMemType42 <> newlineBuilder
+    <> "         minMemType1:            " <> dNumber minMemType1 <> newlineBuilder
+    <> "         maxMemType1:            " <> dNumber maxMemType1 <> newlineBuilder
+    <> dumpPostSubtable
+  where
+    dNumber = (<> Text.Builder.singleton 'd') . Text.Builder.decimal
+    dumpPostSubtable = case postSubtable of
+        None -> "" -- Format 1 and 3 do not require a subtable.
+        PostFormat2 PostFormat2Table{..}
+            -> "         Format 2.0:  Non-Standard (for PostScript) TrueType Glyph Set." <> newlineBuilder
+            <> "                 numGlyphs:      " <> Text.Builder.decimal (Prelude.length glyphNameIndex)
+            <> newlineBuilder <> fold (Vector.imap (dumpFormat2Pair names) glyphNameIndex)
+        PostFormat25 _ -> "Format 2.5"
+        PostFormat4 _ -> "Format 4.0"
+    dumpFormat2Pair names index glyphNameIndex'
+        = "                 Glyf " <> justifyNumber 3 index
+        <> "  -> " <> glyphType names glyphNameIndex'
+        <> newlineBuilder
+    glyphType names glyphNameIndex'
+        | glyphNameIndex' >= 0
+        , glyphNameIndex' <= 257 = "Mac Glyph # " <> justifyNumber 3 glyphNameIndex'
+        | glyphNameIndex' >= 258
+        , glyphNameIndex' <= 32767 =
+            let nameIndex = fromIntegral $ glyphNameIndex' - 258
+             in "PSGlyph Name # " <> justifyNumber 3 (succ nameIndex) <> ", '"
+                <> Text.Builder.fromText (Text.decodeASCII (names Vector.! nameIndex))
+                <> Text.Builder.singleton '\''
+        | otherwise = "Reserved"
+
+dumpCmap :: CmapTable -> Text.Builder.Builder
+dumpCmap CmapTable{..}
+    = dumpCaption "'cmap' Table - Character to Glyph Index Mapping Table"
+    <> "        'cmap' version: " <> Text.Builder.decimal version <> newlineBuilder
+    <> "        number of encodings: " <> Text.Builder.decimal encodingsLength <> newlineBuilder
+    <> "        number of subtables: " <> Text.Builder.decimal (Prelude.length subtables) <> newlineBuilder
+    <> newlineBuilder
+    <> snd (foldr dumpCmapEncoding (pred encodingsLength, "") encodings) <> newlineBuilder
+    <> snd (foldr dumpCmapSubTable (pred subTablesLength, "") subtables) <> newlineBuilder
+  where
+    encodingsLength = Prelude.length encodings
+    subTablesLength = IntMap.size subtables
+    dumpCmapEncoding CmapEncoding{..} (index, accumulator) =
+        let findSubTableIndex = Text.Builder.decimal
+                . Prelude.length
+                . filter ((< offset) . fromIntegral)
+                . IntMap.keys
+            summary = "Encoding   " <> Text.Builder.decimal index
+                <> ".    PlatformID:  " <> Text.Builder.decimal platformID <> newlineBuilder
+                <> "                 EcodingID:   " <> Text.Builder.decimal platformSpecificID <> newlineBuilder
+                <> "                 SubTable: " <> findSubTableIndex subtables
+                <> ", Offset: " <> paddedHexadecimal offset <> newlineBuilder
+         in (pred index, summary <> newlineBuilder <> accumulator)
+    dumpCmapSubTable currentSubTable (index, accumulator) =
+        let contents = "SubTable   " <> Text.Builder.decimal index
+                <> ".    " <> dumpCmapSubTableFormat currentSubTable
+         in (pred index, contents <> accumulator)
+    dumpCmapSubTableFormat = \case
+        (CmapFormat0 _) -> "Format 0"
+        (CmapFormat2 _) -> "Format 2"
+        (CmapFormat4 CmapFormat4Table{..}) ->
+            let segCount = Vector.length startCode
+                dumpSegment' = dumpSegment segCount glyphIndexArray
+             in "Format 4 - Segment mapping to delta values\n\
+                \                 Length:     994\n\
+                \                 Version:      0\n\
+                \                 segCount:       "
+                <> Text.Builder.decimal segCount
+                <> newlineBuilder <> "                 searchRange:    "
+                <> Text.Builder.decimal searchRange
+                <> newlineBuilder <> "                 entrySelector:  "
+                <> Text.Builder.decimal entrySelector
+                <> newlineBuilder <> "                 rangeShift:     "
+                <> Text.Builder.decimal (segCount * 2 - fromIntegral searchRange)
+                <> newlineBuilder
+                <> fold (Vector.izipWith4 (dumpSegmentSummary segCount) startCode endCode idDelta idRangeOffset)
+                <> "                 Number of glyphIndex "
+                <> Text.Builder.decimal (Vector.length glyphIndexArray) <> newlineBuilder
+                <> fold (Vector.imap dumpGlyphAtIndex glyphIndexArray)
+                <> fold (Vector.izipWith4 dumpSegment' startCode endCode idDelta idRangeOffset)
+        (CmapFormat6 _) -> "Format 6"
+        (CmapFormat8 _) -> "Format 8"
+        (CmapFormat10 _) -> "Format 10"
+        (CmapFormat12 _) -> "Format 12"
+        (CmapFormat13 _) -> "Format 13"
+        (CmapFormat14 _) -> "Format 14"
+    dumpSegment :: Int -> Vector Word16 -> Int -> Word16 -> Word16 -> Word16 -> Word16 -> Text.Builder.Builder
+    dumpSegment segCount glyphIndexArray' segmentIndex startCode' endCode' idDelta' idRangeOffset' =
+        let charRange = [startCode'..endCode']
+            dumpSegmentCharIndex' =
+                dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode'
+         in "Segment " <> Text.Builder.decimal segmentIndex <> ":\n"
+            <> foldMap dumpSegmentCharIndex' charRange
+    dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode' charCode =
+        let calculateGlyphIndex' =
+                calculateGlyphIndex charCode segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode'
+         in "                 Char 0x"
+            <> halfPaddedHexadecimal charCode <> " -> Index "
+            <> Text.Builder.decimal calculateGlyphIndex'
+            <> newlineBuilder
+    dumpSegmentSummary segCount index startCode' endCode' idDelta' idRangeOffset'
+        = "                 Seg " <> justifyNumber 5 index
+        <> " : St = " <> halfPaddedHexadecimal startCode'
+        <> ", En = " <> halfPaddedHexadecimal endCode'
+        <> ", D = " <> justifyNumber 6 idDelta'
+        <> ", RO = " <> justifyNumber 6 idRangeOffset'
+        <> ", gId# = " <> dumpGlyphId index segCount idRangeOffset'
+        <> newlineBuilder
+    dumpGlyphId segmentIndex segCount idRangeOffset'
+        = maybe "N/A" Text.Builder.decimal
+        $ calculateGlyphId segmentIndex segCount idRangeOffset'
+    calculateGlyphIndex :: Word16 -> Int -> Int -> Vector Word16 -> Word16 -> Word16 -> Word16 -> Int
+    calculateGlyphIndex c segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode' =
+        let defaultIndex = fromIntegral $ c + idDelta'
+            addOffset = fromIntegral
+                . fromMaybe 0
+                . (glyphIndexArray' Vector.!?)
+                . (+ fromIntegral (c - startCode'))
+         in maybe defaultIndex addOffset
+            $ calculateGlyphId segmentIndex segCount idRangeOffset'
+    calculateGlyphId segmentIndex segCount idRangeOffset'
+        | idRangeOffset' == 0 = Nothing
+        | otherwise = Just $ segmentIndex - segCount + (fromIntegral idRangeOffset' `div` 2)
+    dumpGlyphAtIndex index element = "                 glyphIdArray[" <> Text.Builder.decimal index <> "] =  "
+        <> Text.Builder.decimal element <> newlineBuilder
+
+dumpLoca :: LocaTable -> Text.Builder.Builder
+dumpLoca table =
+    dumpCaption "'loca' Table - Index to Location"
+    <> go table
+  where
+    go (LongLocaTable elements) = dumpElements elements
+    go (ShortLocaTable elements) = dumpElements
+        $ (* 2)
+        . (fromIntegral :: Word16 -> Word32)
+        <$> elements
+    dumpElements elements =
+        case Vector.unsnoc elements of
+            Just (init', last')
+                -> foldMap dumpLocaLine (Vector.indexed init')
+                <> "         Ended at " <> paddedHexadecimal last' <> newlineBuilder
+            Nothing -> mempty
+    dumpLocaLine :: Integral a => (Int, a) -> Text.Builder.Builder
+    dumpLocaLine (index, element)
+        = "         Idx " <> justifyNumber 6 index
+        <> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder
+
+dumpName :: NameTable -> Text.Builder.Builder
+dumpName table'@NameTable{..} = dumpCaption "'name' Table - Naming Table"
+    <> "         Format:                 " <> Text.Builder.decimal format <> newlineBuilder
+    <> "         Number of Record:       " <> Text.Builder.decimal (Prelude.length nameRecord) <> newlineBuilder
+    <> "         Storage offset:         " <> Text.Builder.decimal (nameStringOffset table') <> newlineBuilder
+    <> foldMap go (zip3 [0 :: Int ..] nameRecord variable)
+  where
+    go (index, NameRecord{ length = length', ..}, variable')
+        = "Name table " <> justifyNumber 3 index <> "."
+        <> "  PlatformID:     " <> Text.Builder.decimal platformID <> newlineBuilder
+        <> "                 EncodingID:     " <> Text.Builder.decimal platformSpecificID <> newlineBuilder
+        <> "                 LanguageID:     " <> Text.Builder.decimal languageID <> newlineBuilder
+        <> "                 NameID:         " <> Text.Builder.decimal nameID <> newlineBuilder
+        <> "                 Length:         " <> Text.Builder.decimal length' <> newlineBuilder
+        <> "                 Offset:         " <> Text.Builder.decimal offset <> newlineBuilder
+        <> foldMap ("                 " <>) (dumpHexString $ ByteString.unpack variable')
+
+dumpHexString :: [Word8] -> [Text.Builder.Builder]
+dumpHexString byteCodes
+    | null byteCodes = [dumpHexLine " > " byteCodes]
+    | Prelude.length byteCodes < 10 = [dumpHexLine "  > " byteCodes]
+    | otherwise = dumpHexLine "  >  " byteCodes
+        : dumpHexString (drop 10 byteCodes)
+  where
+    dumpHexLine separator variable' =
+        let firstTen = take 10 variable'
+            digits = fold $ intersperse (Text.Builder.singleton ' ') $ hexByte <$> firstTen
+            printables = foldMap printableByte firstTen
+         in digits
+            <> Text.Builder.fromText (Text.replicate (10 - Prelude.length firstTen) "   ")
+            <> separator
+            <> printables
+            <> newlineBuilder
+    printableByte :: Word8 -> Text.Builder.Builder
+    printableByte code
+        | code >= 0x20
+        , code < 0x7f = Text.Builder.singleton $ toEnum $ fromIntegral code
+        | otherwise = Text.Builder.singleton '.'
+
+hexByte :: Integral a => a -> Text.Builder.Builder
+hexByte = Text.Builder.fromLazyText
+    . Text.Lazy.justifyRight 2 '0'
+    . Text.Builder.toLazyText
+    . Text.Builder.hexadecimal
+
+dumpMaxp :: MaxpTable -> Text.Builder.Builder
+dumpMaxp (TrueMaxp TrueMaxpTable{..})
+    = dumpCaption "'maxp' Table - Maximum Profile"
+    <> "         'maxp' version:         " <> dumpFixed32 version <> newlineBuilder
+    <> "         numGlyphs:              " <> Text.Builder.decimal numGlyphs <> newlineBuilder
+    <> "         maxPoints:              " <> Text.Builder.decimal maxPoints <> newlineBuilder
+    <> "         maxContours:            " <> Text.Builder.decimal maxContours <> newlineBuilder
+    <> "         maxCompositePoints:     " <> Text.Builder.decimal maxComponentPoints <> newlineBuilder
+    <> "         maxCompositeContours:   " <> Text.Builder.decimal maxComponentContours <> newlineBuilder
+    <> "         maxZones:               " <> Text.Builder.decimal maxZones <> newlineBuilder
+    <> "         maxTwilightPoints:      " <> Text.Builder.decimal maxTwilightPoints <> newlineBuilder
+    <> "         maxStorage:             " <> Text.Builder.decimal maxStorage <> newlineBuilder
+    <> "         maxFunctionDefs:        " <> Text.Builder.decimal maxFunctionDefs <> newlineBuilder
+    <> "         maxInstructionDefs:     " <> Text.Builder.decimal maxInstructionDefs <> newlineBuilder
+    <> "         maxStackElements:       " <> Text.Builder.decimal maxStackElements <> newlineBuilder
+    <> "         maxSizeOfInstructions:  " <> Text.Builder.decimal maxSizeOfInstructions <> newlineBuilder
+    <> "         maxComponentElements:   " <> Text.Builder.decimal maxComponentElements <> newlineBuilder
+    <> "         maxCompoenetDepth:      " <> Text.Builder.decimal maxComponentDepth <> newlineBuilder
+dumpMaxp (OpenMaxp OpenMaxpTable{..})
+    = dumpCaption "'maxp' Table - Maximum Profile"
+    <> "         '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 <> ")"
+
+dumpTables
+    :: Megaparsec.State ByteString Void
+    -> FontDirectory
+    -> Either DumpError Text.Builder.Builder
+dumpTables processedState directory@FontDirectory{..}
+    = parseRequired >>= traverseDirectory
+  where
+    traverseDirectory parsedRequired =
+        let initial = Right $ dumpOffsetTable directory
+         in foldl' (go parsedRequired) initial tableDirectory
+    parseRequired = do
+        requiredHhea <- findRequired "hhea" hheaTableP
+        requiredHead@HeadTable{ indexToLocFormat } <-
+            findRequired "head" headTableP
+        requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
+        pure $ RequiredTables
+            { hheaTable = requiredHhea
+            , headTable = requiredHead 
+            , locaTable = requiredLoca
+            } 
+    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 =
+        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 $ Right $ dumpLoca locaTable
+            "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
diff --git a/lib/Graphics/Fountainhead/Parser.hs b/lib/Graphics/Fountainhead/Parser.hs
new file mode 100644
index 0000000..31dcd0e
--- /dev/null
+++ b/lib/Graphics/Fountainhead/Parser.hs
@@ -0,0 +1,1244 @@
+{- 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 DuplicateRecordFields #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Font parser.
+module Graphics.Fountainhead.Parser
+    ( Parser
+    , ParseErrorBundle
+    , cmapTableP
+    , cvTableP
+    , f2Dot14P
+    , fixedP
+    , fontDirectoryP
+    , fpgmTableP
+    , gaspTableP
+    , glyfTableP
+    , hdmxTableP
+    , headTableP
+    , hheaTableP
+    , hmtxTableP
+    , locaTableP
+    , longDateTimeP
+    , longLocaTableP
+    , maxpTableP
+    , nameTableP
+    , os2TableP
+    , panoseP
+    , parseTable
+    , pascalStringP
+    , postTableP
+    , prepTableP
+    , shortLocaTableP
+    , word24P
+    ) where
+
+import Control.Applicative (Alternative(..))
+import Control.Monad (foldM, void)
+import Data.Bits (Bits(..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Builder as ByteString.Builder
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import Data.Foldable (Foldable(..))
+import Data.Int (Int8, Int16)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.Functor (($>))
+import Data.List (sortOn, nubBy, sortBy)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Time
+    ( LocalTime(..)
+    , addDays
+    , secondsToDiffTime
+    , timeToTimeOfDay
+    )
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import Data.Void (Void)
+import Data.Word (Word8, Word16, Word32)
+import GHC.Records (HasField(..))
+import Graphics.Fountainhead.TrueType
+    ( BArmStyle(..)
+    , BContrast(..)
+    , BFamilyType(..)
+    , BMidline(..)
+    , BLetterform(..)
+    , BProportion(..)
+    , BSerifStyle(..)
+    , BStrokeVariation(..)
+    , BWeight(..)
+    , BXHeight(..)
+    , CVTable(..)
+    , CmapSubtable(..)
+    , CmapTable(..)
+    , CmapEncoding(..)
+    , CmapFormat0Table(..)
+    , CmapFormat2Subheader(..)
+    , CmapFormat2Table(..)
+    , CmapFormat4Table(..)
+    , CmapFormat6Table(..)
+    , CmapGroup(..)
+    , CmapFormat8Table(..)
+    , CmapFormat10Table(..)
+    , CmapFormat12Table(..)
+    , CmapFormat13Table
+    , CmapFormat14Table(..)
+    , ComponentGlyphFlags(..)
+    , ComponentGlyphPartDescription(..)
+    , CompoundGlyphDefinition(..)
+    , FpgmTable(..)
+    , FontDirectionHint(..)
+    , FontDirectory(..)
+    , FontStyle(..)
+    , GASPRange(..)
+    , GASPTable(..)
+    , GlyfTable(..)
+    , GlyphArgument(..)
+    , GlyphCoordinate(..)
+    , GlyphDefinition(..)
+    , GlyphDescription(..)
+    , GlyphTransformationOption(..)
+    , HdmxTable(..)
+    , DeviceRecord(..)
+    , HeadTable(..)
+    , HheaTable(..)
+    , HmtxTable(..)
+    , IndexToLocFormat(..)
+    , LocaTable(..)
+    , LongHorMetric(..)
+    , MaxpTable(..)
+    , NameRecord(..)
+    , NameTable(..)
+    , OffsetSubtable(..)
+    , OutlineFlag(..)
+    , OpenMaxpTable(..)
+    , Os2BaseFields(..)
+    , Os2MicrosoftFields(..)
+    , Os2Version1Fields(..)
+    , Os2Version4Fields(..)
+    , Os2Version5Fields(..)
+    , Os2Table(..)
+    , Panose(..)
+    , PostFormat2Table(..)
+    , PostHeader(..)
+    , PostSubtable(..)
+    , PostTable(..)
+    , PrepTable(..)
+    , SimpleGlyphDefinition(..)
+    , TableDirectory(..)
+    , TrueMaxpTable(..)
+    , UVSOffset(..)
+    , UVSMapping(..)
+    , UnicodeValueRange(..)
+    , VariationSelectorMap
+    , unLocaTable
+    )
+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
+
+-- * Font directory
+
+offsetSubtableP :: Parser OffsetSubtable
+offsetSubtableP = OffsetSubtable
+    <$> Megaparsec.Binary.word32be
+    <*> (fromIntegral <$> Megaparsec.Binary.word16be)
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+
+tagP :: Parser ByteString
+tagP = ByteString.Lazy.toStrict
+    . ByteString.Builder.toLazyByteString
+    . ByteString.Builder.word32BE
+    <$> Megaparsec.Binary.word32be
+
+tableDirectoryP :: Parser TableDirectory
+tableDirectoryP = TableDirectory
+    <$> tagP
+    <*> Megaparsec.Binary.word32be
+    <*> (fromIntegral <$> Megaparsec.Binary.word32be)
+    <*> (fromIntegral <$> Megaparsec.Binary.word32be)
+
+fontDirectoryP :: Parser FontDirectory
+fontDirectoryP = do
+    offsetSubtable'@OffsetSubtable{ numTables } <- offsetSubtableP
+    tableDirectories <- Megaparsec.count numTables tableDirectoryP
+    pure $ FontDirectory
+        { offsetSubtable = offsetSubtable'
+        , tableDirectory = tableDirectories
+        }
+
+-- * Name table
+
+nameTableP :: Parser NameTable
+nameTableP = do
+    format' <- Megaparsec.Binary.word16be
+    count' <- fromIntegral <$> Megaparsec.Binary.word16be
+    stringOffset' <- fromIntegral <$> Megaparsec.Binary.word16be
+    nameRecord' <- Megaparsec.count count' nameRecordP
+    -- 12 is the size of a single record, 6 is the header size.
+    let padding = stringOffset' - count' * 12 - 6
+    Megaparsec.skipCount padding Megaparsec.Binary.word8
+    variable' <- Megaparsec.takeRest
+    pure $ NameTable
+        { format = format'
+        , nameRecord = nameRecord'
+        , variable = parseVariable variable' <$> nameRecord'
+        }
+  where
+    parseVariable variable' NameRecord{ offset, length = length' } =
+        ByteString.take length' $ ByteString.drop offset variable'
+
+nameRecordP :: Parser NameRecord
+nameRecordP = NameRecord
+    <$> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> (fromIntegral <$> Megaparsec.Binary.word16be)
+    <*> (fromIntegral <$> Megaparsec.Binary.word16be)
+
+-- * 'cvt ' table
+
+cvTableP :: Parser CVTable
+cvTableP = CVTable
+    <$> Megaparsec.many Megaparsec.Binary.int16be
+    <* Megaparsec.eof
+
+-- * Maximum profile table
+
+trueMaxpTableP :: Parser TrueMaxpTable
+trueMaxpTableP
+    = Megaparsec.chunk (ByteString.pack [0, 1, 0, 0])
+    *> subparser
+  where
+    subparser =
+        TrueMaxpTable (Fixed32 0x00010000)
+            <$> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+            <*> Megaparsec.Binary.word16be
+
+openMaxpTableP :: Parser OpenMaxpTable
+openMaxpTableP
+    = Megaparsec.chunk (ByteString.pack [0, 0, 0x50, 0])
+    *> subparser
+  where
+    subparser =
+        OpenMaxpTable (Fixed32 0x00005000)
+            <$> Megaparsec.Binary.word16be
+            <* Megaparsec.eof
+
+maxpTableP :: Parser MaxpTable
+maxpTableP
+    = TrueMaxp <$> trueMaxpTableP
+    <|> OpenMaxp <$> openMaxpTableP
+
+-- * Horizontal header table
+
+hheaTableP :: Parser HheaTable
+hheaTableP = HheaTable
+    <$> fixedP
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <* Megaparsec.Binary.int16be
+    <* Megaparsec.Binary.int16be
+    <* Megaparsec.Binary.int16be
+    <* Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+    <* Megaparsec.eof
+
+-- * Font header table
+
+headTableP :: Parser HeadTable
+headTableP = HeadTable
+    <$> fixedP
+    <*> fixedP
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> longDateTimeP
+    <*> longDateTimeP
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> fontStyleP
+    <*> Megaparsec.Binary.word16be
+    <*> fontDirectionHintP
+    <*> indexToLocFormatP
+    <*> Megaparsec.Binary.word16be
+    <* Megaparsec.eof
+  where
+    indexToLocFormatP = do
+        indexToLocFormat' <- Megaparsec.Binary.int16be
+        case indexToLocFormat' of
+            0 -> pure ShortOffsetIndexToLocFormat
+            1 -> pure LongOffsetIndexToLocFormat
+            _ -> fail $ "Unknown loca table format indexToLocFormat: "
+                <> show indexToLocFormat'
+
+fontStyleP :: Parser FontStyle
+fontStyleP = go <$> Megaparsec.Binary.word16be
+  where
+    go fontStyle' = FontStyle
+        { bold = testBit fontStyle' 0
+        , italic = testBit fontStyle' 1
+        , underline = testBit fontStyle' 2
+        , outline = testBit fontStyle' 3
+        , shadow = testBit fontStyle' 4
+        , condensed = testBit fontStyle' 5
+        , extended = testBit fontStyle' 6
+        }
+
+fontDirectionHintP :: Parser FontDirectionHint
+fontDirectionHintP
+    = (Megaparsec.chunk (ByteString.pack [0, 0]) $> MixedDirectionalGlyphs)
+    <|> (Megaparsec.chunk (ByteString.pack [0, 1]) $> StronglyLeftToRightGlyphs)
+    <|> (Megaparsec.chunk (ByteString.pack [0, 2]) $> LeftToRightGlyphsWithNeutrals)
+    <|> (Megaparsec.chunk (ByteString.pack [0xff, 0xff]) $> StronglyRightToLeftGlyphs)
+    <|> (Megaparsec.chunk (ByteString.pack [0xff, 0xfe]) $> RightToLeftGlyphsWithNeutrals)
+
+-- * Glyph data location table
+
+longLocaTableP :: Parser LocaTable
+longLocaTableP = LongLocaTable
+    <$> vectorP Megaparsec.Binary.word32be
+    <?> "loca table, long version"
+
+shortLocaTableP :: Parser LocaTable
+shortLocaTableP = ShortLocaTable
+    <$> vectorP Megaparsec.Binary.word16be
+    <?> "loca table, short version"
+
+locaTableP :: IndexToLocFormat -> Parser LocaTable
+locaTableP ShortOffsetIndexToLocFormat = shortLocaTableP
+locaTableP LongOffsetIndexToLocFormat = longLocaTableP
+
+-- * Horizontal metrics table
+
+longHorMetricP :: Parser LongHorMetric
+longHorMetricP = LongHorMetric
+    <$> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.int16be
+
+hmtxTableP :: Word16 -> Parser HmtxTable
+hmtxTableP numOfLongHorMetrics = HmtxTable
+    <$> countP (fromIntegral numOfLongHorMetrics) longHorMetricP
+    <*> Megaparsec.many Megaparsec.Binary.int16be
+
+-- * Glyph name and PostScript font table
+
+postTableP :: Parser PostTable
+postTableP = do
+    header'@PostHeader{ format } <- postHeaderP
+    subtable' <- case format of
+        Fixed32 0x00010000 -> pure None
+        Fixed32 0x00020000 -> PostFormat2 <$> postFormat2TableP
+        Fixed32 0x00025000 -> PostFormat25 <$> postFormat25TableP
+        Fixed32 0x00030000 -> pure None
+        Fixed32 0x00040000 -> PostFormat4 <$> postFormat4TableP
+        _ -> fail $ "Unsupported post table format: " <> show format
+    Megaparsec.eof
+    pure $ PostTable
+        { postHeader = header'
+        , postSubtable = subtable'
+        }
+
+postFormat2TableP :: Parser PostFormat2Table
+postFormat2TableP = do
+    numberOfGlyphs <- fromIntegral <$> Megaparsec.Binary.word16be
+    glyphNameIndex' <- Megaparsec.count numberOfGlyphs Megaparsec.Binary.word16be
+    rest <- Megaparsec.many pascalStringP
+    pure $ PostFormat2Table
+        { glyphNameIndex = Vector.fromList glyphNameIndex'
+        , names = Vector.fromList rest
+        }
+
+postFormat25TableP :: Parser (Vector Int8)
+postFormat25TableP = Megaparsec.Binary.word16be
+    >>= fmap Vector.fromList
+    . flip Megaparsec.count Megaparsec.Binary.int8
+    . fromIntegral
+
+postFormat4TableP :: Parser (Vector Word16)
+postFormat4TableP = Vector.fromList
+    <$> Megaparsec.many Megaparsec.Binary.word16be
+
+postHeaderP :: Parser PostHeader
+postHeaderP = PostHeader
+    <$> fixedP
+    <*> fixedP
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+
+-- * Font program table
+
+fpgmTableP :: Parser FpgmTable
+fpgmTableP = FpgmTable
+    <$> vectorP Megaparsec.Binary.word8
+
+-- * Prep table
+
+prepTableP :: Parser PrepTable
+prepTableP = PrepTable
+    <$> vectorP Megaparsec.Binary.word8
+
+-- * Horizontal device metrics table
+
+deviceRecordP :: Int -> Parser DeviceRecord
+deviceRecordP size = do
+    pixelSize' <- Megaparsec.Binary.word8
+    maximumWidth' <- Megaparsec.Binary.word8
+    widths' <- vectorNP size Megaparsec.Binary.word8
+    let paddingLength = 4 - ((Vector.length widths' + 2) `mod` 4)
+    Megaparsec.skipCount paddingLength
+        $ Megaparsec.chunk
+        $ ByteString.pack [0]
+    pure $ DeviceRecord
+        { pixelSize = pixelSize'
+        , maximumWidth = maximumWidth'
+        , widths = widths'
+        }
+
+hdmxTableP :: Parser HdmxTable
+hdmxTableP = do
+    void $ Megaparsec.chunk $ ByteString.pack [0, 0]
+    numberOfDeviceRecords <- fromIntegral <$> Megaparsec.Binary.int16be
+    sizeOfDeviceRecord <- fromIntegral <$> Megaparsec.Binary.int32be
+    records' <- Megaparsec.count numberOfDeviceRecords
+        $ deviceRecordP sizeOfDeviceRecord
+    Megaparsec.eof
+    pure $ HdmxTable 0 records'
+
+-- * Glyph outline table
+
+glyphDescriptionP :: Parser GlyphDescription
+glyphDescriptionP = do
+    numberOfContours' <- fromIntegral
+        <$> Megaparsec.Binary.int16be
+        <?> "numberOfContours"
+    xMin' <- Megaparsec.Binary.int16be <?> "xMin"
+    yMin' <- Megaparsec.Binary.int16be <?> "yMin"
+    xMax' <- Megaparsec.Binary.int16be <?> "xMax"
+    yMax' <- Megaparsec.Binary.int16be <?> "yMax"
+    glyphDefinition <-
+        if numberOfContours' >= 0
+        then SimpleGlyph <$> simpleGlyphDefinitionP numberOfContours'
+        else CompoundGlyph <$> compoundGlyphDefinitionP
+    pure $ GlyphDescription
+        { numberOfContours = numberOfContours'
+        , xMin = xMin'
+        , yMin = yMin'
+        , xMax = xMax'
+        , yMax = yMax'
+        , definition = glyphDefinition
+        }
+
+glyphInstructionsP :: Parser (Vector Word8)
+glyphInstructionsP = Megaparsec.Binary.word16be
+    >>= flip vectorNP (Megaparsec.Binary.word8 <?> "compound glyph instruction")
+    . fromIntegral
+
+compoundGlyphDefinitionP :: Parser CompoundGlyphDefinition
+compoundGlyphDefinitionP = do
+    components' <- componentGlyphPartDescriptionP mempty
+    let instructions' =
+            if Vector.any (weHaveInstructions . getField @"flags") components'
+            then glyphInstructionsP
+            else pure mempty
+    CompoundGlyphDefinition components' <$> instructions'
+
+componentGlyphPartDescriptionP
+    ::Vector ComponentGlyphPartDescription
+    -> Parser (Vector ComponentGlyphPartDescription)
+componentGlyphPartDescriptionP accumulator = do
+    flags' <- Megaparsec.Binary.word16be <?> "flags"
+    glyphIndex' <- Megaparsec.Binary.word16be <?> "glyphIndex"
+    let arg1And2AreWords = testBit flags' 0
+        argsAreXyValues = testBit flags' 1
+        weHaveAScale =  testBit flags' 3
+        weHaveAnXAndYScale =  testBit flags' 6
+        weHaveATwoByTwo =  testBit flags' 7
+    argument1 <- glyphArgumentP arg1And2AreWords argsAreXyValues <?> "argument1"
+    argument2 <- glyphArgumentP arg1And2AreWords argsAreXyValues <?> "argument2"
+    transformationOption' <- transformationOptionP weHaveAScale weHaveAnXAndYScale weHaveATwoByTwo
+        <?> "transformation option"
+
+    let updated = Vector.snoc accumulator $ ComponentGlyphPartDescription
+            { flags = ComponentGlyphFlags
+                { roundXyToGrid = testBit flags' 2
+                , weHaveInstructions = testBit flags' 8
+                , useMyMetrics = testBit flags' 9
+                , overlapCompound = testBit flags' 10
+                }
+            , glyphIndex = glyphIndex'
+            , argument1 = argument1
+            , argument2 = argument2
+            , transformationOption = transformationOption'
+            }
+    -- 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
+    <$> f2Dot14P
+    <*> f2Dot14P
+    <?> "xy-scale"
+transformationOptionP _ _ True = Glyph2By2Scale
+    <$> f2Dot14P
+    <*> f2Dot14P
+    <*> f2Dot14P
+    <*> f2Dot14P
+    <?> "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
+    <?> "int16 argument"
+glyphArgumentP True False = GlyphWord16Argument
+    <$> Megaparsec.Binary.word16be
+    <?> "uint16 argument"
+glyphArgumentP False True = GlyphInt8Argument
+    <$> Megaparsec.Binary.int8
+    <?> "int8 argument"
+glyphArgumentP False False = GlyphWord8Argument
+    <$> Megaparsec.Binary.word8
+    <?> "uint8 argument"
+
+simpleGlyphDefinitionP :: Int -> Parser SimpleGlyphDefinition
+simpleGlyphDefinitionP numberOfContours' = do
+    endPtsOfContours' <- vectorNP numberOfContours' Megaparsec.Binary.word16be
+        <?> "endPtsOfContours"
+    let numberOfPoints =
+            if Vector.null endPtsOfContours'
+            then 0
+            else fromIntegral $ Vector.last endPtsOfContours'
+    instructionLength <- fromIntegral
+        <$> Megaparsec.Binary.word16be
+        <?> "instructionLength"
+    instructions' <- vectorNP instructionLength
+            (Megaparsec.Binary.word8 <?> "simple glyph instruction")
+    flags' <- flagsP numberOfPoints mempty <?> "flags"
+    xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags'
+    ys <- Vector.foldM (coordinatesP yFlagPair) mempty flags'
+    pure $ SimpleGlyphDefinition
+        { endPtsOfContours = endPtsOfContours'
+        , instructions = instructions'
+        , flags = flags'
+        , coordinates = mkCoordinate <$> Vector.zip xs ys
+        }
+  where
+    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 :: 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)
+    coordinatesP get accumulator first =
+        let parser = uncurry coordinateP $ get first
+            repeatN = succIntegral $ getField @"repeat" first
+         in (accumulator <>) <$> vectorNP repeatN parser
+    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
+                    }
+            flagsP (remaining - repeatN - 1)
+                $ Vector.snoc accumulator flag'
+
+glyfTableP :: LocaTable -> Parser GlyfTable
+glyfTableP locaTable
+    | locaTable' <- unLocaTable locaTable
+    , not $ Vector.null locaTable' =
+        let locaInit = Vector.init locaTable'
+            offsets = traverse go
+                $ nubBy duplicate
+                $ sortOn fst
+                $ filter filterNullLength
+                $ Vector.toList
+                $ Vector.zip locaInit
+                $ Vector.tail locaTable'
+         in GlyfTable
+            . Vector.generate (Vector.length locaInit)
+            . generateTable locaInit
+            . IntMap.fromList
+            <$> offsets
+    | otherwise = pure $ GlyfTable mempty
+  where
+    filterNullLength (x, y) = x /= y
+    duplicate x y = fst x == fst y
+    generateTable :: Vector Word32 -> IntMap GlyphDescription -> Int -> GlyphDescription
+    generateTable locaInit offsetMap index =
+        offsetMap IntMap.! fromIntegral (locaInit Vector.! index)
+    go (locaOffset, nextOffset) = do
+        startOffset <- Megaparsec.getOffset
+        result <- glyphDescriptionP
+        endOffset <- Megaparsec.getOffset
+        flip Megaparsec.skipCount Megaparsec.Binary.word8
+            $ fromIntegral nextOffset
+            - fromIntegral locaOffset
+            - endOffset
+            + startOffset
+        pure (fromIntegral locaOffset, result)
+
+-- * Character to glyph mapping table
+
+cmapTableP :: Parser CmapTable
+cmapTableP = do
+    initialOffset <- Megaparsec.getOffset
+    version' <- Megaparsec.Binary.word16be
+    numberSubtables <- fromIntegral <$> Megaparsec.Binary.word16be
+    encodings' <- sortOn (getField @"offset")
+        <$> Megaparsec.count numberSubtables cmapHeaderP
+    parsedSubtables <- Megaparsec.some (subtableAtOffset initialOffset)
+    Megaparsec.eof
+    pure $ CmapTable
+        { version = version'
+        , encodings = encodings'
+        , subtables = IntMap.fromList parsedSubtables
+        }
+  where
+    subtableAtOffset initialOffset = do
+        currentOffset <- flip (-) initialOffset <$> Megaparsec.getOffset
+        parsedSubtable <- cmapFormatTableP
+        pure (currentOffset, parsedSubtable)
+
+cmapHeaderP :: Parser CmapEncoding
+cmapHeaderP = CmapEncoding
+    <$> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word32be
+
+cmapFormatTableP :: Parser CmapSubtable
+cmapFormatTableP = do
+    format' <- Megaparsec.Binary.word16be
+    case format' of
+        0 -> CmapFormat0 <$> cmapFormat0TableP
+        2 -> CmapFormat2 <$> cmapFormat2TableP
+        4 -> CmapFormat4 <$> cmapFormat4TableP
+        6 -> CmapFormat6 <$> cmapFormat6TableP
+        8 -> CmapFormat8 <$> cmapFormat8TableP
+        10 -> CmapFormat10 <$> cmapFormat10TableP
+        12 -> CmapFormat12 <$> cmapFormat12TableP
+        13 -> CmapFormat13 <$> cmapFormat13TableP
+        14 -> CmapFormat14 <$> cmapFormat14TableP
+        _ -> fail $ "Unsupported format " <> show format' <> "."
+
+cmapFormat14TableP :: Parser CmapFormat14Table
+cmapFormat14TableP = do
+    initialOffset <- (+ (-2)) <$> Megaparsec.getOffset
+    void Megaparsec.Binary.word32be -- Length.
+    numVarSelectorRecords <- fromIntegral <$> Megaparsec.Binary.word32be
+    variationSelectorRecords' <- sortBy sortOffset . fold
+        <$> Megaparsec.count numVarSelectorRecords variationSelectorRecordP
+    let parseByOffset' = parseByOffset initialOffset
+    CmapFormat14Table <$> foldM parseByOffset' IntMap.empty variationSelectorRecords'
+  where
+    parseByOffset
+        :: Int
+        -> VariationSelectorMap
+        -> UVSOffset Word32 Word32
+        -> Parser VariationSelectorMap
+    parseByOffset _ accumulator uvsOffset'
+        | uvsOffset uvsOffset' == 0 = pure accumulator
+    parseByOffset tableOffset accumulator (DefaultUVSOffset varSelector' relativeOffset)
+        -- If the records at this offset were already parsed, look at any parsed
+        -- record and duplicate it updating the varSelector. The same logic
+        -- applies for the next pattern match, but for non-default UVS.
+        | Just member@(DefaultUVSOffset _ record :| _) <-
+            IntMap.lookup (fromIntegral relativeOffset) accumulator =
+
+            let newRecord = DefaultUVSOffset varSelector' record NonEmpty.<| member
+                relativeOffset' = fromIntegral relativeOffset
+             in pure $ IntMap.insert relativeOffset' newRecord accumulator
+        | otherwise = do
+            currentOffset <- Megaparsec.getOffset
+            let emptyBytes = tableOffset + fromIntegral relativeOffset - currentOffset
+                relativeOffset' = fromIntegral relativeOffset
+            void $ Megaparsec.takeP Nothing emptyBytes
+            entryCount <- fromIntegral <$> Megaparsec.Binary.word32be
+            valueRanges <- vectorNP entryCount unicodeValueRangeP
+            pure $ IntMap.insert relativeOffset' (DefaultUVSOffset varSelector' valueRanges :| []) accumulator
+    parseByOffset tableOffset accumulator (NonDefaultUVSOffset varSelector' relativeOffset)
+        | Just member@(NonDefaultUVSOffset _ record :| _) <-
+            IntMap.lookup (fromIntegral relativeOffset) accumulator =
+
+            let newRecord = NonDefaultUVSOffset varSelector' record NonEmpty.<| member
+                relativeOffset' = fromIntegral relativeOffset
+             in pure $ IntMap.insert relativeOffset' newRecord accumulator
+        | otherwise = do
+            currentOffset <- Megaparsec.getOffset
+            let emptyBytes = tableOffset + fromIntegral relativeOffset - currentOffset
+            void $ Megaparsec.takeP Nothing emptyBytes
+            entryCount <- fromIntegral <$> Megaparsec.Binary.word32be
+            flip (IntMap.insert $ fromIntegral relativeOffset) accumulator
+                . pure
+                . NonDefaultUVSOffset varSelector'
+                <$> vectorNP entryCount uvsMappingP
+    sortOffset x y = compare (uvsOffset x) (uvsOffset y)
+
+uvsOffset :: forall a. UVSOffset a a -> a
+uvsOffset (DefaultUVSOffset _ x) = x
+uvsOffset (NonDefaultUVSOffset _ x) = x
+
+variationSelectorRecordP :: Parser [UVSOffset Word32 Word32]
+variationSelectorRecordP = do
+    varSelector' <- word24P
+    defaultUVSOffset' <- Megaparsec.Binary.word32be
+    nonDefaultUVSOffset' <- Megaparsec.Binary.word32be
+
+    pure
+        [ DefaultUVSOffset varSelector' defaultUVSOffset'
+        , NonDefaultUVSOffset varSelector' nonDefaultUVSOffset'
+        ]
+
+uvsMappingP :: Parser UVSMapping
+uvsMappingP = UVSMapping
+    <$> word24P
+    <*> Megaparsec.Binary.word16be
+
+unicodeValueRangeP :: Parser UnicodeValueRange
+unicodeValueRangeP = UnicodeValueRange
+    <$> word24P
+    <*> Megaparsec.Binary.word8
+
+cmapFormat13TableP :: Parser CmapFormat13Table
+cmapFormat13TableP = cmapFormat12TableP
+
+cmapFormat12TableP :: Parser CmapFormat12Table
+cmapFormat12TableP = do
+    void $ Megaparsec.takeP Nothing 6 -- Reserved and length.
+    language' <- Megaparsec.Binary.word32be
+    nGroups <- fromIntegral <$> Megaparsec.Binary.word32be
+    groups' <- vectorNP nGroups cmapGroupP
+
+    pure $ CmapFormat12Table
+        { language = language'
+        , groups = groups'
+        }
+
+cmapFormat10TableP :: Parser CmapFormat10Table
+cmapFormat10TableP = do
+    void $ Megaparsec.takeP Nothing 2 -- Reserved.
+    length' <- fromIntegral <$> Megaparsec.Binary.word32be
+    language' <- Megaparsec.Binary.word32be
+    startCharCode' <- Megaparsec.Binary.word32be
+    numChars' <- Megaparsec.Binary.word32be
+    let remainingLength = div (length' - 24) 2
+    glyphs' <- vectorNP remainingLength Megaparsec.Binary.word16be
+
+    pure $ CmapFormat10Table
+        { language = language'
+        , startCharCode = startCharCode'
+        , numChars = numChars'
+        , glyphs = glyphs'
+        }
+
+cmapFormat8TableP :: Parser CmapFormat8Table
+cmapFormat8TableP = do
+    void $ Megaparsec.takeP Nothing 6 -- Reserved and length.
+    language' <- Megaparsec.Binary.word32be
+    is32' <- Megaparsec.takeP Nothing 65536
+    nGroups <- fromIntegral <$> Megaparsec.Binary.word32be
+    groups' <- vectorNP nGroups cmapGroupP
+
+    pure $ CmapFormat8Table
+        { language = language'
+        , is32 = ByteString.unpack is32'
+        , groups = groups'
+        }
+
+cmapGroupP :: Parser CmapGroup
+cmapGroupP = CmapGroup
+    <$> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+
+cmapFormat6TableP :: Parser CmapFormat6Table
+cmapFormat6TableP = do
+    void Megaparsec.Binary.word16be -- Length.
+    language' <- Megaparsec.Binary.word16be
+    firstCode' <- Megaparsec.Binary.word16be
+    entryCount' <- fromIntegral <$> Megaparsec.Binary.word16be
+    glyphIndexArray' <- vectorNP entryCount' Megaparsec.Binary.word16be
+
+    pure $ CmapFormat6Table
+        { language = language'
+        , firstCode = firstCode'
+        , glyphIndexArray = glyphIndexArray'
+        }
+
+cmapFormat4TableP :: Parser CmapFormat4Table
+cmapFormat4TableP = do
+    length' <- fromIntegral <$> Megaparsec.Binary.word16be
+    language' <- Megaparsec.Binary.word16be
+    segCount <- fromIntegral . (`div` 2) <$> Megaparsec.Binary.word16be
+    searchRange' <- Megaparsec.Binary.word16be
+    entrySelector' <- Megaparsec.Binary.word16be
+    rangeShift' <- Megaparsec.Binary.word16be
+    endCode' <- vectorNP segCount Megaparsec.Binary.word16be
+    void $ Megaparsec.chunk $ ByteString.pack [0, 0] -- reservedPad 0.
+    startCode' <- vectorNP segCount Megaparsec.Binary.word16be
+    idDelta' <- vectorNP segCount Megaparsec.Binary.word16be
+    idRangeOffset' <- vectorNP segCount Megaparsec.Binary.word16be
+    let glyphIndexLength = div (length' - 16 - segCount * 8) 2
+    glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be
+
+    pure $ CmapFormat4Table
+        { language = language'
+        , searchRange = searchRange'
+        , entrySelector = entrySelector'
+        , rangeShift = rangeShift'
+        , endCode = endCode'
+        , startCode = startCode'
+        , idDelta = idDelta'
+        , idRangeOffset = idRangeOffset'
+        , glyphIndexArray = glyphIndexArray'
+        }
+
+cmapFormat2TableP :: Parser CmapFormat2Table
+cmapFormat2TableP = do
+    length' <- fromIntegral <$> Megaparsec.Binary.word16be
+    language' <- Megaparsec.Binary.word16be
+    subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be
+    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
+
+    pure $ CmapFormat2Table
+        { language = language'
+        , subHeaderKeys = subHeaderKeys'
+        , subHeaders = subHeaders'
+        , glyphIndexArray = glyphIndexArray'
+        }
+
+cmapFormat2SubheaderP :: Parser CmapFormat2Subheader
+cmapFormat2SubheaderP = CmapFormat2Subheader
+    <$> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+
+cmapFormat0TableP :: Parser CmapFormat0Table
+cmapFormat0TableP = CmapFormat0Table
+    <$> Megaparsec.Binary.word16be
+    <* Megaparsec.Binary.word16be
+    <*> vectorNP 256 Megaparsec.Binary.word8
+
+-- * Generic parsing utilities
+
+word24P :: Parser Word32
+word24P = foldr unstep 0 . ByteString.unpack
+    <$> Megaparsec.takeP (Just "word24") 3
+  where
+    unstep b a = a `shiftL` 8 .|. fromIntegral b
+
+f2Dot14P :: Parser F2Dot14
+f2Dot14P = F2Dot14 <$> Megaparsec.Binary.int16be
+
+vectorP :: forall a. Parser a -> Parser (Vector a)
+vectorP = fmap Vector.fromList . Megaparsec.many
+
+vectorNP :: forall a. Int -> Parser a -> Parser (Vector a)
+vectorNP size = fmap Vector.fromList . Megaparsec.count size
+
+pascalStringP :: Parser ByteString
+pascalStringP = Megaparsec.Binary.word8
+    >>= fmap ByteString.pack
+    . flip Megaparsec.count Megaparsec.Binary.word8
+    . fromIntegral
+
+countP :: forall a. Int -> Parser a -> Parser (NonEmpty a)
+countP number parser
+    = (:|)
+    <$> parser
+    <*> Megaparsec.count (number - 1) parser
+
+longDateTimeP :: Parser LocalTime
+longDateTimeP = go <$> Megaparsec.Binary.int64be
+  where
+    go totalSeconds =
+        let (totalDays, secondsOfDay) = totalSeconds `divMod` (3600 * 24)
+         in LocalTime
+            { localDay = addDays (fromIntegral totalDays) ttfEpoch
+            , localTimeOfDay = timeToTimeOfDay
+                $ secondsToDiffTime
+                $ fromIntegral secondsOfDay
+            }
+
+fixedP :: Parser Fixed32
+fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be
+
+parseTable
+    :: TableDirectory
+    -> Parser a
+    -> Megaparsec.State ByteString Void
+    -> Either ParseErrorBundle a
+parseTable TableDirectory{ offset, length = length' } parser state = snd
+    $ Megaparsec.runParser' parser 
+    $ state
+        { Megaparsec.stateInput = stateInput
+        , Megaparsec.stateOffset = stateOffset
+        , Megaparsec.statePosState = posState
+            { Megaparsec.pstateInput = stateInput
+            , Megaparsec.pstateOffset = stateOffset
+            }
+        }
+  where
+    posState = Megaparsec.statePosState state
+    stateInput = ByteString.take length'
+        $ ByteString.drop (offset - Megaparsec.stateOffset state)
+        $ Megaparsec.stateInput state
+    stateOffset = offset
+
+-- * OS/2 table
+
+os2TableP :: Parser Os2Table
+os2TableP = do
+    baseFields <- os2BaseFieldsP
+    result <- case getField @"version" baseFields of
+        0 -> Os2Version0 baseFields
+            <$> Megaparsec.optional os2MicrosoftFieldsP
+        1 -> Os2Version1 baseFields
+            <$> os2MicrosoftFieldsP
+            <*> os2Version1FieldsP
+        2 -> Os2Version2 baseFields
+            <$> os2MicrosoftFieldsP
+            <*> os2Version4FieldsP
+        3 -> Os2Version3 baseFields
+            <$> os2MicrosoftFieldsP
+            <*> os2Version4FieldsP
+        4 -> Os2Version4 baseFields
+            <$> os2MicrosoftFieldsP
+            <*> os2Version4FieldsP
+        5 -> Os2Version5 baseFields
+            <$> os2MicrosoftFieldsP
+            <*> os2Version5FieldsP
+        unsupportedVersion -> fail
+            $ "Unsupported OS/2 version: " <> show unsupportedVersion
+    Megaparsec.eof
+    pure result
+
+os2BaseFieldsP :: Parser Os2BaseFields
+os2BaseFieldsP = Os2BaseFields
+    <$> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> panoseP
+    <*> vectorNP 4 Megaparsec.Binary.word32be
+    <*> vectorNP 4 Megaparsec.Binary.int8
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+
+os2MicrosoftFieldsP :: Parser Os2MicrosoftFields
+os2MicrosoftFieldsP = Os2MicrosoftFields
+    <$> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+
+os2Version1FieldsP :: Parser Os2Version1Fields
+os2Version1FieldsP = Os2Version1Fields
+    <$> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+
+os2Version4FieldsP :: Parser Os2Version4Fields
+os2Version4FieldsP = Os2Version4Fields
+    <$> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+
+os2Version5FieldsP :: Parser Os2Version5Fields
+os2Version5FieldsP = Os2Version5Fields
+    <$> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.word32be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.int16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+    <*> Megaparsec.Binary.word16be
+
+panoseP :: Parser Panose
+panoseP = Panose
+    <$> bFamilyTypeP
+    <*> bSerifStyleP
+    <*> bWeightP
+    <*> bProportionP
+    <*> bContrastP
+    <*> bStrokeVariationP
+    <*> bArmStyleP
+    <*> bLetterformP
+    <*> bMidlineP
+    <*> bXHeightP
+
+bFamilyTypeP :: Parser BFamilyType
+bFamilyTypeP
+    = (Megaparsec.single 0 $> AnyFamilyType)
+    <|> (Megaparsec.single 1 $> NoFitFamilyType)
+    <|> (Megaparsec.single 2 $> TextAndDisplayFamilyType)
+    <|> (Megaparsec.single 3 $> ScriptFamilyType)
+    <|> (Megaparsec.single 4 $> DecorativeFamilyType)
+    <|> (Megaparsec.single 5 $> PictorialFamilyType)
+    <?> "bFamilyType"
+
+bSerifStyleP :: Parser BSerifStyle
+bSerifStyleP
+    = (Megaparsec.single 0 $> AnySerifStyle)
+    <|> (Megaparsec.single 1 $> NoFitSerifStyle)
+    <|> (Megaparsec.single 2 $> CoveSerifStyle)
+    <|> (Megaparsec.single 3 $> ObtuseCoveSerifStyle)
+    <|> (Megaparsec.single 4 $> SquareCoveSerifStyle)
+    <|> (Megaparsec.single 5 $> ObtuseSquareCoveSerifStyle)
+    <|> (Megaparsec.single 6 $> SquareSerifStyle)
+    <|> (Megaparsec.single 7 $> ThinSerifStyle)
+    <|> (Megaparsec.single 8 $> BoneSerifStyle)
+    <|> (Megaparsec.single 9 $> ExaggeratedSerifStyle)
+    <|> (Megaparsec.single 10 $> TriangleSerifStyle)
+    <|> (Megaparsec.single 11 $> NormalSansSerifStyle)
+    <|> (Megaparsec.single 12 $> ObtuseSansSerifStyle)
+    <|> (Megaparsec.single 13 $> PerpSansSerifStyle)
+    <|> (Megaparsec.single 14 $> FlaredSerifStyle)
+    <|> (Megaparsec.single 15 $> RoundedSerifStyle)
+    <?> "bSerifStyle"
+
+bWeightP :: Parser BWeight
+bWeightP
+    = (Megaparsec.single 0 $> AnyWeight)
+    <|> (Megaparsec.single 1 $> NoFitWeight)
+    <|> (Megaparsec.single 2 $> VeryLightWeight)
+    <|> (Megaparsec.single 3 $> LightWeight)
+    <|> (Megaparsec.single 4 $> ThinWeight)
+    <|> (Megaparsec.single 5 $> BookWeight)
+    <|> (Megaparsec.single 6 $> MediumWeight)
+    <|> (Megaparsec.single 7 $> DemiWeight)
+    <|> (Megaparsec.single 8 $> BoldWeight)
+    <|> (Megaparsec.single 9 $> HeavyWeight)
+    <|> (Megaparsec.single 10 $> BlackWeight)
+    <|> (Megaparsec.single 11 $> NordWeight)
+    <?> "bWeight"
+
+bProportionP :: Parser BProportion
+bProportionP
+    = (Megaparsec.single 0 $> AnyProportion)
+    <|> (Megaparsec.single 1 $> NoFitProportion)
+    <|> (Megaparsec.single 2 $> OldStyleProportion)
+    <|> (Megaparsec.single 3 $> ModernProportion)
+    <|> (Megaparsec.single 4 $> EvenWidthProportion)
+    <|> (Megaparsec.single 5 $> ExpandedProportion)
+    <|> (Megaparsec.single 6 $> CondensedProportion)
+    <|> (Megaparsec.single 7 $> VeryExpandedProportion)
+    <|> (Megaparsec.single 8 $> VeryCondensedProportion)
+    <|> (Megaparsec.single 9 $> MonospacedProportion)
+    <?> "bProportion"
+
+bContrastP :: Parser BContrast
+bContrastP
+    = (Megaparsec.single 0 $> AnyContrast)
+    <|> (Megaparsec.single 1 $> NoFitContrast)
+    <|> (Megaparsec.single 2 $> NoneContrast)
+    <|> (Megaparsec.single 3 $> VeryLowContrast)
+    <|> (Megaparsec.single 4 $> LowContrast)
+    <|> (Megaparsec.single 5 $> MediumLowContrast)
+    <|> (Megaparsec.single 6 $> MediumContrast)
+    <|> (Megaparsec.single 7 $> MediumHighContrast)
+    <|> (Megaparsec.single 8 $> HighContrast)
+    <|> (Megaparsec.single 9 $> VeryHighContrast)
+    <?> "bContrast"
+
+bStrokeVariationP :: Parser BStrokeVariation
+bStrokeVariationP
+    = (Megaparsec.single 0 $> AnyStrokeVariation)
+    <|> (Megaparsec.single 1 $> NoFitStrokeVariation)
+    <|> (Megaparsec.single 2 $> GradualDiagonalStrokeVariation)
+    <|> (Megaparsec.single 3 $> GradualTransitionalStrokeVariation)
+    <|> (Megaparsec.single 4 $> GradualVerticalStrokeVariation)
+    <|> (Megaparsec.single 5 $> GradualHorizontalStrokeVariation)
+    <|> (Megaparsec.single 6 $> RapidVerticalStrokeVariation)
+    <|> (Megaparsec.single 7 $> RapidHorizontalStrokeVariation)
+    <|> (Megaparsec.single 8 $> InstantVerticalStrokeVariation)
+    <?> "bStrokeVariation"
+
+bArmStyleP :: Parser BArmStyle
+bArmStyleP
+    = (Megaparsec.single 0 $> AnyArmStyle)
+    <|> (Megaparsec.single 1 $> NoFitArmStyle)
+    <|> (Megaparsec.single 2 $> StraightArmsHorizontalArmStyle)
+    <|> (Megaparsec.single 3 $> StraightArmsWedgeArmStyle)
+    <|> (Megaparsec.single 4 $> StraightArmsVerticalArmStyle)
+    <|> (Megaparsec.single 5 $> StraightArmsSingleSerifArmStyle)
+    <|> (Megaparsec.single 6 $> StraightArmsDoubleSerifArmStyle)
+    <|> (Megaparsec.single 7 $> NonStraightArmsHorizontalArmStyle)
+    <|> (Megaparsec.single 8 $> NonStraightArmsWedgeArmStyle)
+    <|> (Megaparsec.single 9 $> NonStraightArmsVerticalArmStyle)
+    <|> (Megaparsec.single 10 $> NonStraightArmsSingleSerifArmStyle)
+    <|> (Megaparsec.single 11 $> NonStraightArmsDoubleSerifArmStyle)
+    <?> "bArmStyle"
+
+bLetterformP :: Parser BLetterform
+bLetterformP
+    = (Megaparsec.single 0 $> AnyLetterform)
+    <|> (Megaparsec.single 1 $> NoFitLetterform)
+    <|> (Megaparsec.single 2 $> NormalContactLetterform)
+    <|> (Megaparsec.single 3 $> NormalWeightedLetterform)
+    <|> (Megaparsec.single 4 $> NormalBoxedLetterform)
+    <|> (Megaparsec.single 5 $> NormalFlattenedLetterform)
+    <|> (Megaparsec.single 6 $> NormalRoundedLetterform)
+    <|> (Megaparsec.single 7 $> NormalOffCenterLetterform)
+    <|> (Megaparsec.single 8 $> NormalSquareLetterform)
+    <|> (Megaparsec.single 9 $> ObliqueContactLetterform)
+    <|> (Megaparsec.single 10 $> ObliqueWeightedLetterform)
+    <|> (Megaparsec.single 11 $> ObliqueBoxedLetterform)
+    <|> (Megaparsec.single 12 $> ObliqueFlattenedLetterform)
+    <|> (Megaparsec.single 13 $> ObliqueRoundedLetterform)
+    <|> (Megaparsec.single 14 $> ObliqueOffCenterLetterform)
+    <|> (Megaparsec.single 15 $> ObliqueSquareLetterform)
+    <?> "bLetterform"
+
+bXHeightP :: Parser BXHeight
+bXHeightP
+    = (Megaparsec.single 0 $> AnyXHeight)
+    <|> (Megaparsec.single 1 $> NoFitXHeight)
+    <|> (Megaparsec.single 2 $>  ConstantSmallXHeight)
+    <|> (Megaparsec.single 3 $>  ConstantStandardXHeight)
+    <|> (Megaparsec.single 4 $>  ConstantLargeXHeight)
+    <|> (Megaparsec.single 5 $>  DuckingSmallXHeight)
+    <|> (Megaparsec.single 6 $>  DuckingStandardXHeight)
+    <|> (Megaparsec.single 7 $>  DuckingLargeXHeight)
+    <?> "bXHeight"
+
+bMidlineP :: Parser BMidline
+bMidlineP
+    = (Megaparsec.single 0 $> AnyMidline)
+    <|> (Megaparsec.single 1 $> NoFitMidline)
+    <|> (Megaparsec.single 2 $> StandardTrimmedMidline)
+    <|> (Megaparsec.single 3 $> StandardPointedMidline)
+    <|> (Megaparsec.single 4 $> StandardSerifedMidline)
+    <|> (Megaparsec.single 5 $> HighTrimmedMidline)
+    <|> (Megaparsec.single 6 $> HighPointedMidline)
+    <|> (Megaparsec.single 7 $> HighSerifedMidline)
+    <|> (Megaparsec.single 8 $> ConstantTrimmedMidline)
+    <|> (Megaparsec.single 9 $> ConstantPointedMidline)
+    <|> (Megaparsec.single 10 $> ConstantSerifedMidline)
+    <|> (Megaparsec.single 11 $> LowTrimmedMidline)
+    <|> (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
diff --git a/lib/Graphics/Fountainhead/TrueType.hs b/lib/Graphics/Fountainhead/TrueType.hs
new file mode 100644
index 0000000..0c15081
--- /dev/null
+++ b/lib/Graphics/Fountainhead/TrueType.hs
@@ -0,0 +1,1318 @@
+{- 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 DuplicateRecordFields #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Types representing a TrueType font.
+module Graphics.Fountainhead.TrueType
+    ( BArmStyle(..)
+    , BContrast(..)
+    , BFamilyType(..)
+    , BLetterform(..)
+    , BMidline(..)
+    , BProportion(..)
+    , BSerifStyle(..)
+    , BStrokeVariation(..)
+    , BWeight(..)
+    , BXHeight(..)
+    , CVTable(..)
+    , CmapSubtable(..)
+    , CmapTable(..)
+    , CmapEncoding(..)
+    , CmapFormat0Table(..)
+    , CmapFormat2Subheader(..)
+    , CmapFormat2Table(..)
+    , CmapFormat4Table(..)
+    , CmapFormat6Table(..)
+    , CmapGroup(..)
+    , CmapFormat8Table(..)
+    , CmapFormat10Table(..)
+    , CmapFormat12Table(..)
+    , CmapFormat13Table
+    , CmapFormat14Table(..)
+    , ComponentGlyphFlags(..)
+    , ComponentGlyphPartDescription(..)
+    , CompoundGlyphDefinition(..)
+    , DeviceRecord(..)
+    , FpgmTable(..)
+    , FontDirectionHint(..)
+    , FontDirectory(..)
+    , FontStyle(..)
+    , GASPRange(..)
+    , GASPTable(..)
+    , GlyfTable(..)
+    , GlyphArgument(..)
+    , GlyphCoordinate(..)
+    , GlyphDefinition(..)
+    , GlyphDescription(..)
+    , GlyphTransformationOption(..)
+    , HdmxTable(..)
+    , HeadTable(..)
+    , HheaTable(..)
+    , HmtxTable(..)
+    , IndexToLocFormat(..)
+    , LocaTable(..)
+    , LongHorMetric(..)
+    , MaxpTable(..)
+    , NameRecord(..)
+    , NameTable(..)
+    , OffsetSubtable(..)
+    , OpenMaxpTable(..)
+    , Os2BaseFields(..)
+    , Os2MicrosoftFields(..)
+    , Os2Table(..)
+    , Os2Version1Fields(..)
+    , Os2Version4Fields(..)
+    , Os2Version5Fields(..)
+    , OutlineFlag(..)
+    , Panose(..)
+    , PostFormat2Table(..)
+    , PostHeader(..)
+    , PostSubtable(..)
+    , PostTable(..)
+    , PrepTable(..)
+    , RangeGaspBehavior(..)
+    , SimpleGlyphDefinition(..)
+    , TableDirectory(..)
+    , TrueMaxpTable(..)
+    , UVSOffset(..)
+    , UVSMapping(..)
+    , UnicodeValueRange(..)
+    , VariationSelectorMap
+    , unLocaTable
+    , nameStringOffset
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.Int (Int8, Int16)
+import Data.IntMap (IntMap)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Time (LocalTime(..))
+import Data.Vector (Vector)
+import Data.Word (Word8, Word16, Word32)
+import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), FWord, UFWord)
+
+-- * Font directory
+
+data FontDirectory = FontDirectory
+    { offsetSubtable :: OffsetSubtable
+    , tableDirectory :: [TableDirectory]
+    } deriving (Eq, Show)
+
+data OffsetSubtable = OffsetSubtable
+    { scalerType :: Word32
+    , numTables :: Int
+    , searchRange :: Word16
+    , entrySelector :: Word16
+    , rangeShift :: Word16
+    } deriving (Eq, Show)
+
+data TableDirectory = TableDirectory
+    { tag :: ByteString
+    , checkSum :: Word32
+    , offset :: Int
+    , length :: Int
+    } deriving (Eq, Show)
+
+-- * Name table
+
+data NameTable = NameTable
+    { format :: Word16 -- ^ Format selector. Set to 0.
+    , nameRecord :: [NameRecord] -- ^ The name records array.
+    , variable :: [ByteString] -- ^ The character strings of the names.
+    } deriving (Eq, Show)
+
+data NameRecord = NameRecord
+    { platformID :: Word16 -- ^ Platform identifier code.
+    , platformSpecificID :: Word16 -- ^ Platform-specific encoding identifier.
+    , languageID :: Word16 -- ^  Language identifier.
+    , nameID :: Word16 -- ^ Name identifier.
+    , length :: Int -- ^ Name string length in bytes.
+    , offset :: Int -- ^ Offset.
+    } deriving (Eq, Show)
+
+nameStringOffset :: NameTable -> Word16
+nameStringOffset NameTable{..} =
+    let nameRecordSize = 12
+        precedingFieldsSize = 2 * 3
+     in nameRecordSize * fromIntegral (Prelude.length nameRecord) + precedingFieldsSize
+
+-- * 'cvt ' table
+
+newtype CVTable = CVTable [Int16]
+    deriving (Eq, Show)
+
+-- * Maximum profile table
+
+data TrueMaxpTable = TrueMaxpTable
+    { version :: Fixed32 -- ^ 0x00010000 (1.0).
+    , numGlyphs :: Word16 -- ^ The number of glyphs in the font.
+    , maxPoints :: Word16 -- ^ Points in non-compound glyph.
+    , maxContours :: Word16 -- ^ Contours in non-compound glyph.
+    , maxComponentPoints :: Word16 -- ^ Points in compound glyph.
+    , maxComponentContours :: Word16 -- ^ Contours in compound glyph.
+    , maxZones :: Word16 -- ^ Set to 2.
+    , maxTwilightPoints :: Word16 -- ^ Points used in Twilight Zone (Z0).
+    , maxStorage :: Word16 -- ^ Number of Storage Area locations.
+    , maxFunctionDefs :: Word16 -- ^ Number of FDEFs.
+    , maxInstructionDefs :: Word16 -- ^ Number of IDEFs.
+    , maxStackElements :: Word16 -- ^ Maximum stack depth.
+    , maxSizeOfInstructions :: Word16 -- ^ Byte count for glyph instructions.
+    , maxComponentElements :: Word16 -- ^ Number of glyphs referenced at top level.
+    , maxComponentDepth :: Word16 -- ^ Levels of recursion, set to 0 if font has only simple glyphs.
+    } deriving (Eq, Show)
+
+data OpenMaxpTable = OpenMaxpTable
+    { version :: Fixed32 -- ^ 0x00005000 (0.5).
+    , numGlyphs :: Word16 -- ^ The number of glyphs in the font.
+    } deriving (Eq, Show)
+
+data MaxpTable = OpenMaxp OpenMaxpTable | TrueMaxp TrueMaxpTable
+    deriving (Eq, Show)
+
+-- * Horizontal header table
+
+data HheaTable = HheaTable
+    { version :: Fixed32 -- ^ 0x00010000 (1.0).
+    , ascent :: FWord -- ^ Distance from baseline of highest ascender.
+    , descent :: FWord -- ^ Distance from baseline of lowest descender.
+    , lineGap :: FWord -- ^ Typographic line gap.
+    , advanceWidthMax :: UFWord -- ^ Must be consistent with horizontal metrics.
+    , minLeftSideBearing :: FWord -- ^ Must be consistent with horizontal metrics.
+    , minRightSideBearing :: FWord -- ^ Must be consistent with horizontal metrics.
+    , xMaxExtent :: FWord -- ^ max(lsb + (xMax-xMin)).
+    , caretSlopeRise :: Int16 -- ^ used to calculate the slope of the caret (rise/run) set to 1 for vertical caret.
+    , caretSlopeRun :: Int16 -- ^ 0 for vertical.
+    , caretOffset :: FWord -- ^ Set value to 0 for non-slanted fonts.
+    , metricDataFormat :: Int16 -- ^ 0 for current format.
+    , numOfLongHorMetrics :: Word16 -- ^ Number of advance widths in metrics table.
+    } deriving (Eq, Show)
+
+-- * Font header table
+
+data IndexToLocFormat
+    = ShortOffsetIndexToLocFormat
+    | LongOffsetIndexToLocFormat
+    deriving (Eq, Show)
+
+data HeadTable = HeadTable
+    { version :: Fixed32 -- ^ 0x00010000 if (version 1.0).
+    , fontRevision :: Fixed32 -- ^ Set by font manufacturer.
+    , checkSumAdjustment :: Word32 -- ^ To compute: set it to 0, calculate the checksum for the 'head' table and put it in the table directory, sum the entire font as a uint32_t, then store 0xB1B0AFBA - sum. (The checksum for the 'head' table will be wrong as a result. That is OK; do not reset it.)
+    , magicNumber :: Word32 -- ^ Set to 0x5F0F3CF5.
+    , flags :: Word16
+    , unitsPerEm :: Word16 -- ^ Range from 64 to 16384.
+    , created :: LocalTime -- ^ International date.
+    , modified :: LocalTime -- ^ International date.
+    , xMin :: Int16 -- ^ For all glyph bounding boxes.
+    , yMin :: Int16 -- ^ For all glyph bounding boxes.
+    , xMax :: Int16 -- ^ For all glyph bounding boxes.
+    , yMax :: Int16 -- ^ For all glyph bounding boxes.
+    , macStyle :: FontStyle
+    , lowestRecPPEM :: Word16 -- ^ Smallest readable size in pixels.
+    , fontDirectionHint :: FontDirectionHint -- ^ 0 Mixed directional glyphs.
+    , indexToLocFormat :: IndexToLocFormat -- ^ 0 for short offsets, 1 for long.
+    , glyphDataFormat :: Word16 -- ^ 0 for current format.
+    } deriving (Eq, Show)
+
+data FontStyle = FontStyle
+    { bold :: Bool
+    , italic :: Bool
+    , underline :: Bool
+    , outline :: Bool
+    , shadow :: Bool
+    , condensed :: Bool
+    , extended :: Bool
+    } deriving (Eq, Show)
+
+data FontDirectionHint
+    = MixedDirectionalGlyphs -- ^ 0. Mixed directional glyphs.
+    | StronglyLeftToRightGlyphs -- ^ 1. Only strongly left to right glyphs.
+    | LeftToRightGlyphsWithNeutrals -- ^ 2. Like 1 but also contains neutrals.
+    | StronglyRightToLeftGlyphs -- ^ -1. Only strongly right to left glyphs.
+    | RightToLeftGlyphsWithNeutrals -- ^ -2. Like -1 but also contains neutrals.
+    deriving (Eq, Show)
+
+data LocaTable
+    = ShortLocaTable (Vector Word16)
+    | LongLocaTable (Vector Word32)
+    deriving (Eq, Show)
+
+unLocaTable :: LocaTable -> Vector Word32
+unLocaTable (LongLocaTable values') = values'
+unLocaTable (ShortLocaTable values') = (* 2) . fromIntegral <$> values'
+
+-- * Horizontal metrics table
+
+data LongHorMetric = LongHorMetric
+    { advanceWidth :: Word16
+    , leftSideBearing :: Int16
+    } deriving (Eq, Show)
+
+data HmtxTable = HmtxTable
+    { hMetrics :: NonEmpty LongHorMetric
+    , leftSideBearing :: [Int16]
+    } deriving (Eq, Show)
+
+-- * Glyph name and PostScript font table
+
+data PostHeader = PostHeader
+    { format :: Fixed32 -- ^ Format of this table
+    , 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)
+    , 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
+    , maxMemType1 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 1 font
+    } deriving (Eq, Show)
+
+data PostFormat2Table = PostFormat2Table
+    { glyphNameIndex :: Vector Word16 -- ^ Ordinal number of this glyph in 'post' string tables. This is not an offset.
+    , names :: Vector ByteString
+    } deriving (Eq, Show)
+
+data PostSubtable
+    = None
+    | PostFormat2 PostFormat2Table
+    | PostFormat25 (Vector Int8)
+    | PostFormat4 (Vector Word16)
+    deriving (Eq, Show)
+
+data PostTable = PostTable
+    { postHeader :: PostHeader
+    , postSubtable :: PostSubtable
+    } deriving (Eq, Show)
+
+-- * Font program table
+
+newtype FpgmTable = FpgmTable (Vector Word8)
+    deriving (Eq, Show)
+
+-- * Prep table
+
+newtype PrepTable = PrepTable (Vector Word8)
+    deriving (Eq, Show)
+
+-- * Horizontal device metrics table
+
+data HdmxTable = HdmxTable
+    { format :: Int16 -- ^ Format version number.
+    , records :: [DeviceRecord]
+    } deriving (Eq, Show)
+
+data DeviceRecord = DeviceRecord
+    { pixelSize :: Word8 -- ^ Pixel size for following widths.
+    , maximumWidth :: Word8 -- ^ Maximum width.
+    , widths :: Vector Word8 -- ^ Widths.
+    } deriving (Eq, Show)
+
+-- * Glyph outline table
+
+data GlyphDescription = GlyphDescription
+    { numberOfContours :: Int
+    , xMin :: Int16 -- ^ Minimum x for coordinate data.
+    , yMin :: Int16 -- ^ Minimum y for coordinate data.
+    , xMax :: Int16 -- ^ Maximum x for coordinate data.
+    , yMax :: Int16 -- ^ Maximum y for coordinate data.
+    , definition :: GlyphDefinition
+    } deriving (Eq, Show)
+
+data GlyphArgument
+    = GlyphInt16Argument Int16
+    | GlyphWord16Argument Word16
+    | GlyphInt8Argument Int8
+    | GlyphWord8Argument Word8
+    deriving (Eq, Show)
+
+data GlyphTransformationOption
+    = GlyphNoScale
+    | GlyphScale F2Dot14
+    | GlyphXyScale F2Dot14 F2Dot14
+    | Glyph2By2Scale F2Dot14 F2Dot14 F2Dot14 F2Dot14
+    deriving (Eq, Show)
+
+data SimpleGlyphDefinition = SimpleGlyphDefinition
+    -- | Array of last points of each contour; n is the number of contours;
+    -- array entries are point indices.
+    { 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
+    } deriving (Eq, Show)
+
+data CompoundGlyphDefinition = CompoundGlyphDefinition
+    { components :: Vector ComponentGlyphPartDescription
+    , instructions :: Vector Word8
+    } deriving (Eq, Show)
+
+data GlyphDefinition
+    = SimpleGlyph SimpleGlyphDefinition
+    | CompoundGlyph CompoundGlyphDefinition
+    deriving (Eq, Show)
+
+data ComponentGlyphFlags = ComponentGlyphFlags
+    { roundXyToGrid :: Bool
+    , weHaveInstructions :: Bool
+    , useMyMetrics :: Bool
+    , overlapCompound :: Bool
+    } deriving (Eq, Show)
+
+data GlyphCoordinate = GlyphCoordinate
+    { coordinateX :: Int16
+    , coordinateY :: Int16
+    } 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
+    , argument1 :: GlyphArgument
+    , argument2 :: GlyphArgument
+    , transformationOption :: GlyphTransformationOption
+    } deriving (Eq, Show)
+
+-- * Glyph outline table
+
+data OutlineFlag = OutlineFlag
+    { onCurve :: Bool
+    , xShortVector :: Bool
+    , yShortVector :: Bool
+    , repeat :: Word8
+    , thisXIsSame :: Bool
+    , thisYIsSame :: Bool
+    } deriving (Eq, Show)
+
+newtype GlyfTable = GlyfTable (Vector GlyphDescription)
+    deriving (Eq, Show)
+
+-- 'cmap' table
+
+-- | Character to glyph mapping table.
+data CmapTable = CmapTable
+    { version :: Word16 -- ^ Version number is zero.
+    -- | Encodings with an offset into subtables map.
+    , encodings :: [CmapEncoding]
+    -- ^ The key into the map is the offset in the 'CmapEncoding's.
+    , subtables :: IntMap CmapSubtable
+    } deriving (Eq, Show)
+
+data CmapEncoding = CmapEncoding
+    { platformID :: Word16 -- ^ Platform identifier
+    , platformSpecificID :: Word16 -- ^ Platform-specific encoding identifier.
+    , offset :: Word32 -- ^ Offst of the mapping table.
+    } deriving (Eq, Show)
+
+data CmapFormat0Table = CmapFormat0Table
+    { language :: Word16 -- ^ Language code.
+    , glyphIndexArray :: Vector Word8 -- ^ An array that maps character codes to glyph index values.
+    } deriving (Eq, Show)
+
+data CmapFormat2Subheader = CmapFormat2Subheader
+    { firstCode :: Word16
+    , entryCount :: Word16
+    , idDelta :: Int16
+    , idRangeOffset :: Word16
+    } deriving (Eq, Show)
+
+data CmapFormat2Table = CmapFormat2Table
+    { language :: Word16 -- ^ Language code.
+    , subHeaderKeys :: Vector Word16 -- ^ Array that maps high bytes to subHeaders: value is index * 8.
+    , subHeaders :: Vector CmapFormat2Subheader -- ^ Variable length array of subHeader structures.
+    , glyphIndexArray :: Vector Word16 -- ^ Variable length array containing subarrays.
+    } deriving (Eq, Show)
+
+data CmapFormat4Table = CmapFormat4Table
+    { language :: Word16 -- ^ Language code.
+    , searchRange :: Word16 -- ^ 2 * (2**FLOOR(log2(segCount))).
+    , entrySelector :: Word16 -- ^ log2(searchRange/2).
+    , rangeShift :: Word16 -- ^ (2 * segCount) - searchRange.
+    , endCode :: Vector Word16 -- ^ Ending character code for each segment, last = 0xFFFF.
+    , startCode :: Vector Word16 -- ^ Starting character code for each segment.
+    , idDelta :: Vector Word16 -- ^ Delta for all character codes in segment.
+    , idRangeOffset :: Vector Word16 -- ^ Offset in bytes to glyph indexArray, or 0.
+    , glyphIndexArray :: Vector Word16 -- ^ Glyph index array.
+    } deriving (Eq, Show)
+
+data CmapFormat6Table = CmapFormat6Table
+    { language :: Word16 -- ^ Language code.
+    , firstCode :: Word16 -- ^ First character code of subrange.
+    , glyphIndexArray :: Vector Word16 -- ^ Array of glyph index values for character codes in the range
+    } deriving (Eq, Show)
+
+data CmapGroup = CmapGroup
+    -- | First character code in this group; note that if this group is for one
+    -- or more 16-bit character codes (which is determined from the is32 array),
+    -- this 32-bit value will have the high 16-bits set to zero.
+    { startCharCode :: Word32
+    -- | Last character code in this group; same condition as listed above for
+    -- the startCharCode.
+    , endCharCode :: Word32
+    -- | Glyph index corresponding to the starting character code.
+    , startGlyphCode :: Word32
+    } deriving (Eq, Show)
+
+data CmapFormat8Table = CmapFormat8Table
+    { language :: Word32 -- ^ Language code.
+    -- | Tightly packed array of bits (8K bytes total) indicating whether the
+    -- particular 16-bit (index) value is the start of a 32-bit character code.
+    , is32 :: [Word8]
+    -- | Word32 Number of groupings which follow.
+    , groups :: Vector CmapGroup
+    } deriving (Eq, Show)
+
+data CmapFormat10Table = CmapFormat10Table
+    { language :: Word32 -- ^ Language code.
+    , startCharCode :: Word32 -- ^ First character code covered.
+    , numChars :: Word32 -- ^ Number of character codes covered.
+    , glyphs :: Vector Word16 -- ^ Array of glyph indices for the character codes covered.
+    } deriving (Eq, Show)
+
+data CmapFormat12Table = CmapFormat12Table
+    { language :: Word32 -- ^ Language code.
+    , groups :: Vector CmapGroup
+    } deriving (Eq, Show)
+
+type CmapFormat13Table = CmapFormat12Table
+
+newtype CmapFormat14Table = CmapFormat14Table
+    { varSelectorRecords :: VariationSelectorMap
+    } deriving (Eq, Show)
+
+data CmapSubtable
+    = CmapFormat0 CmapFormat0Table
+    | CmapFormat2 CmapFormat2Table
+    | CmapFormat4 CmapFormat4Table
+    | CmapFormat6 CmapFormat6Table
+    | CmapFormat8 CmapFormat8Table
+    | CmapFormat10 CmapFormat10Table
+    | CmapFormat12 CmapFormat12Table
+    | CmapFormat13 CmapFormat13Table
+    | CmapFormat14 CmapFormat14Table
+    deriving (Eq, Show)
+
+data UVSOffset a b = DefaultUVSOffset Word32 a | NonDefaultUVSOffset Word32 b
+    deriving (Eq, Show)
+
+data UVSMapping = UVSMapping
+    { unicodeValue :: Word32 -- ^ Base Unicode value of the UVS.
+    , glyphID :: Word16 -- ^ Glyph ID of the UVS.
+    } deriving (Eq, Show)
+
+data UnicodeValueRange = UnicodeValueRange
+    { startUnicodeValue :: Word32 -- ^ First value in this range.
+    , additionalCount :: Word8 -- ^ Number of additional values in this range.
+    } deriving (Eq, Show)
+
+-- | Mapping from variation selector record offsets to the record data.
+type VariationSelectorMap = IntMap
+    (NonEmpty (UVSOffset (Vector UnicodeValueRange) (Vector UVSMapping)))
+
+-- * OS/2 table
+
+data Os2Table
+    = Os2Version0 Os2BaseFields (Maybe Os2MicrosoftFields)
+    | Os2Version1 Os2BaseFields Os2MicrosoftFields Os2Version1Fields
+    | Os2Version2 Os2BaseFields Os2MicrosoftFields Os2Version4Fields
+    | Os2Version3 Os2BaseFields Os2MicrosoftFields Os2Version4Fields
+    | Os2Version4 Os2BaseFields Os2MicrosoftFields Os2Version4Fields
+    | Os2Version5 Os2BaseFields Os2MicrosoftFields Os2Version5Fields
+    deriving (Eq, Show)
+
+data Os2Version1Fields = Os2Version1Fields
+    { ulCodePageRange1 :: Word32
+    , ulCodePageRange2 :: Word32
+    } deriving (Eq, Show)
+
+data Os2MicrosoftFields = Os2MicrosoftFields
+    { sTypoAscender :: Int16
+    , sTypoDescender :: Int16
+    , sTypoLineGap :: Int16
+    , usWinAscent :: Word16
+    , usWinDescent :: Word16
+    } deriving (Eq, Show)
+
+data Os2Version4Fields = Os2Version4Fields
+    { ulCodePageRange1 :: Word32
+    , ulCodePageRange2 :: Word32
+    , sxHeight :: Int16
+    , sCapHeight :: Int16
+    , usDefaultChar :: Word16
+    , usBreakChar :: Word16
+    , usMaxContext :: Word16
+    } deriving (Eq, Show)
+
+data Os2Version5Fields = Os2Version5Fields
+    { ulCodePageRange1 :: Word32
+    , ulCodePageRange2 :: Word32
+    , sxHeight :: Int16
+    , sCapHeight :: Int16
+    , usDefaultChar :: Word16
+    , usBreakChar :: Word16
+    , usMaxContext :: Word16
+    , usLowerOpticalPointSize :: Word16
+    , usUpperOpticalPointSize :: Word16
+    } deriving (Eq, Show)
+
+data Os2BaseFields = Os2BaseFields
+    { version :: Word16 -- ^ Table version number (set to 0).
+    -- | Average weighted advance width of lower case letters and space.
+    , xAvgCharWidth :: Int16
+    -- | Visual weight (degree of blackness or thickness) of stroke in glyphs.
+    , usWeightClass :: Word16
+    -- | Relative change from the normal aspect ratio (width to height ratio)
+    -- as specified by a font designer for the glyphs in the font.
+    , usWidthClass :: Word16
+    -- | Characteristics and properties of this font (set undefined bits to
+    -- zero).
+    , fsType :: Int16
+    -- | Recommended horizontal size in pixels for subscripts.
+    , ySubscriptXSize :: Int16
+    -- | Recommended vertical size in pixels for subscripts.
+    , ySubscriptYSize :: Int16
+    -- | Recommended horizontal offset for subscripts.
+    , ySubscriptXOffset :: Int16
+    -- | Recommended vertical offset form the baseline for subscripts.
+    , ySubscriptYOffset :: Int16
+    -- | Recommended horizontal size in pixels for superscripts.
+    , ySuperscriptXSize :: Int16
+    -- | Recommended vertical size in pixels for superscripts.
+    , ySuperscriptYSize :: Int16
+    -- | Recommended horizontal offset for superscripts.
+    , ySuperscriptXOffset :: Int16
+    -- | Recommended vertical offset from the baseline for superscripts.
+    , ySuperscriptYOffset :: Int16
+    -- | Width of the strikeout stroke.
+    , yStrikeoutSize :: Int16
+    -- | Position of the strikeout stroke relative to the baseline.
+    , yStrikeoutPosition :: Int16
+    -- ^ Classification of font-family design.
+    , sFamilyClass :: Int16
+    -- | 10 byte series of number used to describe the visual characteristics
+    -- of a given typeface.
+    , panose :: Panose
+    -- | Field is split into two bit fields of 96 and 36 bits each. The low 96
+    -- bits are used to specify the Unicode blocks encompassed by the font file.
+    -- The high 32 bits are used to specify the character or script sets covered
+    -- by the font file. Bit assignments are pending. Set to 0.
+    , ulUnicodeRange :: Vector Word32
+    -- | Four character identifier for the font vendor.
+    , achVendID :: Vector Int8
+    -- | 2-byte bit field containing information concerning the nature of the
+    -- font patterns.
+    , fsSelection :: Word16
+    -- | The minimum Unicode index in this font.
+    , fsFirstCharIndex :: Word16
+    -- | The maximum Unicode index in this font.
+    , fsLastCharIndex :: Word16
+    } deriving (Eq, Show)
+
+data Panose = Panose
+    { bFamilyType :: BFamilyType
+    , bSerifStyle :: BSerifStyle
+    , bWeight :: BWeight
+    , bProportion :: BProportion
+    , bContrast :: BContrast
+    , bStrokeVariation :: BStrokeVariation
+    , bArmStyle :: BArmStyle
+    , bLetterform :: BLetterform
+    , bMidline :: BMidline
+    , bXHeight :: BXHeight
+    } deriving (Eq, Show)
+
+data BFamilyType
+    = AnyFamilyType
+    | NoFitFamilyType
+    | TextAndDisplayFamilyType
+    | ScriptFamilyType
+    | DecorativeFamilyType
+    | PictorialFamilyType
+    deriving Eq
+
+instance Show BFamilyType
+  where
+    show AnyFamilyType = "Any"
+    show NoFitFamilyType = "No Fit"
+    show TextAndDisplayFamilyType = "Text and Display"
+    show ScriptFamilyType = "Script"
+    show DecorativeFamilyType = "Decorative"
+    show PictorialFamilyType = "Pictorial"
+
+instance Enum BFamilyType
+  where
+    toEnum 0 = AnyFamilyType
+    toEnum 1 = NoFitFamilyType
+    toEnum 2 = TextAndDisplayFamilyType
+    toEnum 3 = ScriptFamilyType
+    toEnum 4 = DecorativeFamilyType
+    toEnum 5 = PictorialFamilyType
+    toEnum _ = error "Unknown family type"
+    fromEnum AnyFamilyType = 0
+    fromEnum NoFitFamilyType = 1
+    fromEnum TextAndDisplayFamilyType = 2
+    fromEnum ScriptFamilyType = 3
+    fromEnum DecorativeFamilyType = 4
+    fromEnum PictorialFamilyType = 5
+
+data BSerifStyle
+    = AnySerifStyle
+    | NoFitSerifStyle
+    | CoveSerifStyle
+    | ObtuseCoveSerifStyle
+    | SquareCoveSerifStyle
+    | ObtuseSquareCoveSerifStyle
+    | SquareSerifStyle
+    | ThinSerifStyle
+    | BoneSerifStyle
+    | ExaggeratedSerifStyle
+    | TriangleSerifStyle
+    | NormalSansSerifStyle
+    | ObtuseSansSerifStyle
+    | PerpSansSerifStyle
+    | FlaredSerifStyle
+    | RoundedSerifStyle
+    deriving Eq
+
+instance Show BSerifStyle
+  where
+    show AnySerifStyle = "Any"
+    show NoFitSerifStyle = "No Fit"
+    show CoveSerifStyle = "Cove"
+    show ObtuseCoveSerifStyle = "Obtuse Cove"
+    show SquareCoveSerifStyle = "Square Cove"
+    show ObtuseSquareCoveSerifStyle = "Obtuse Square Cove"
+    show SquareSerifStyle = "Square"
+    show ThinSerifStyle = "Thin"
+    show BoneSerifStyle = "Bone"
+    show ExaggeratedSerifStyle = "Exaggerated"
+    show TriangleSerifStyle = "Triangle"
+    show NormalSansSerifStyle = "Normal Sans"
+    show ObtuseSansSerifStyle = "Obtuse Sans"
+    show PerpSansSerifStyle = "Perp Sans"
+    show FlaredSerifStyle = "Flared"
+    show RoundedSerifStyle = "Rounded"
+
+instance Enum BSerifStyle
+  where
+    toEnum 0 = AnySerifStyle
+    toEnum 1 = NoFitSerifStyle
+    toEnum 2 = CoveSerifStyle
+    toEnum 3 = ObtuseCoveSerifStyle
+    toEnum 4 = SquareCoveSerifStyle
+    toEnum 5 = ObtuseSquareCoveSerifStyle
+    toEnum 6 = SquareSerifStyle
+    toEnum 7 = ThinSerifStyle
+    toEnum 8 = BoneSerifStyle
+    toEnum 9 = ExaggeratedSerifStyle
+    toEnum 10 = TriangleSerifStyle
+    toEnum 11 = NormalSansSerifStyle
+    toEnum 12 = ObtuseSansSerifStyle
+    toEnum 13 = PerpSansSerifStyle
+    toEnum 14 = FlaredSerifStyle
+    toEnum 15 = RoundedSerifStyle
+    toEnum _ = error "Unknown serif type"
+    fromEnum AnySerifStyle = 0
+    fromEnum NoFitSerifStyle = 1
+    fromEnum CoveSerifStyle = 2
+    fromEnum ObtuseCoveSerifStyle = 3
+    fromEnum SquareCoveSerifStyle = 4
+    fromEnum ObtuseSquareCoveSerifStyle = 5
+    fromEnum SquareSerifStyle = 6
+    fromEnum ThinSerifStyle = 7
+    fromEnum BoneSerifStyle = 8
+    fromEnum ExaggeratedSerifStyle = 9
+    fromEnum TriangleSerifStyle = 10
+    fromEnum NormalSansSerifStyle = 11
+    fromEnum ObtuseSansSerifStyle = 12
+    fromEnum PerpSansSerifStyle = 13
+    fromEnum FlaredSerifStyle = 14
+    fromEnum RoundedSerifStyle = 15
+
+data BWeight
+    = AnyWeight
+    | NoFitWeight
+    | VeryLightWeight
+    | LightWeight
+    | ThinWeight
+    | BookWeight
+    | MediumWeight
+    | DemiWeight
+    | BoldWeight
+    | HeavyWeight
+    | BlackWeight
+    | NordWeight
+    deriving Eq
+
+instance Show BWeight
+  where
+    show AnyWeight = "Any"
+    show NoFitWeight = "No Fit"
+    show VeryLightWeight = "Very Light"
+    show LightWeight = "Light"
+    show ThinWeight = "Thin"
+    show BookWeight = "Book"
+    show MediumWeight = "Medium"
+    show DemiWeight = "Demi"
+    show BoldWeight = "Bold"
+    show HeavyWeight = "Heavy"
+    show BlackWeight = "Black"
+    show NordWeight = "Nord"
+
+instance Enum BWeight
+  where
+    fromEnum AnyWeight = 0
+    fromEnum NoFitWeight = 1
+    fromEnum VeryLightWeight = 2
+    fromEnum LightWeight = 3
+    fromEnum ThinWeight = 4
+    fromEnum BookWeight = 5
+    fromEnum MediumWeight = 6
+    fromEnum DemiWeight = 7
+    fromEnum BoldWeight = 8
+    fromEnum HeavyWeight = 9
+    fromEnum BlackWeight = 10
+    fromEnum NordWeight = 11
+    toEnum 0 = AnyWeight
+    toEnum 1 = NoFitWeight
+    toEnum 2 = VeryLightWeight
+    toEnum 3 = LightWeight
+    toEnum 4 = ThinWeight
+    toEnum 5 = BookWeight
+    toEnum 6 = MediumWeight
+    toEnum 7 = DemiWeight
+    toEnum 8 = BoldWeight
+    toEnum 9 = HeavyWeight
+    toEnum 10 = BlackWeight
+    toEnum 11 = NordWeight
+    toEnum _ = error "Unknown weight"
+
+data BProportion
+    = AnyProportion
+    | NoFitProportion
+    | OldStyleProportion
+    | ModernProportion
+    | EvenWidthProportion
+    | ExpandedProportion
+    | CondensedProportion
+    | VeryExpandedProportion
+    | VeryCondensedProportion
+    | MonospacedProportion
+    deriving Eq
+
+instance Show BProportion
+  where
+    show AnyProportion = "Any"
+    show NoFitProportion = "No Fit"
+    show OldStyleProportion = "Old Style"
+    show ModernProportion = "Modern"
+    show EvenWidthProportion = "Even Width"
+    show ExpandedProportion = "Expanded"
+    show CondensedProportion = "Condensed"
+    show VeryExpandedProportion = "Very Expanded"
+    show VeryCondensedProportion = "Very Condensed"
+    show MonospacedProportion = "Monospaced"
+
+instance Enum BProportion
+  where
+    fromEnum AnyProportion = 0
+    fromEnum NoFitProportion = 1
+    fromEnum OldStyleProportion = 2
+    fromEnum ModernProportion = 3
+    fromEnum EvenWidthProportion = 4
+    fromEnum ExpandedProportion = 5
+    fromEnum CondensedProportion = 6
+    fromEnum VeryExpandedProportion = 7
+    fromEnum VeryCondensedProportion = 8
+    fromEnum MonospacedProportion = 9
+    toEnum 0 = AnyProportion
+    toEnum 1 = NoFitProportion
+    toEnum 2 = OldStyleProportion
+    toEnum 3 = ModernProportion
+    toEnum 4 = EvenWidthProportion
+    toEnum 5 = ExpandedProportion
+    toEnum 6 = CondensedProportion
+    toEnum 7 = VeryExpandedProportion
+    toEnum 8 = VeryCondensedProportion
+    toEnum 9 = MonospacedProportion
+    toEnum _ = error "Unknown proportion"
+
+data BContrast
+    = AnyContrast
+    | NoFitContrast
+    | NoneContrast
+    | VeryLowContrast
+    | LowContrast
+    | MediumLowContrast
+    | MediumContrast
+    | MediumHighContrast
+    | HighContrast
+    | VeryHighContrast
+    deriving Eq
+
+instance Show BContrast
+  where
+    show AnyContrast = "Any"
+    show NoFitContrast = "No Fit"
+    show NoneContrast = "None"
+    show VeryLowContrast = "Very Low"
+    show LowContrast = "Low"
+    show MediumLowContrast = "Medium Low"
+    show MediumContrast = "Medium"
+    show MediumHighContrast = "Medium High"
+    show HighContrast = "High"
+    show VeryHighContrast = "Very High"
+
+instance Enum BContrast
+  where
+    fromEnum AnyContrast = 0
+    fromEnum NoFitContrast = 1
+    fromEnum NoneContrast = 2
+    fromEnum VeryLowContrast = 3
+    fromEnum LowContrast = 4
+    fromEnum MediumLowContrast = 5
+    fromEnum MediumContrast = 6
+    fromEnum MediumHighContrast = 7
+    fromEnum HighContrast = 8
+    fromEnum VeryHighContrast = 9
+    toEnum 0 = AnyContrast
+    toEnum 1 = NoFitContrast
+    toEnum 2 = NoneContrast
+    toEnum 3 = VeryLowContrast
+    toEnum 4 = LowContrast
+    toEnum 5 = MediumLowContrast
+    toEnum 6 = MediumContrast
+    toEnum 7 = MediumHighContrast
+    toEnum 8 = HighContrast
+    toEnum 9 = VeryHighContrast
+    toEnum _ = error "Unknown contrast"
+
+data BStrokeVariation
+    = AnyStrokeVariation
+    | NoFitStrokeVariation
+    | GradualDiagonalStrokeVariation
+    | GradualTransitionalStrokeVariation
+    | GradualVerticalStrokeVariation
+    | GradualHorizontalStrokeVariation
+    | RapidVerticalStrokeVariation
+    | RapidHorizontalStrokeVariation
+    | InstantVerticalStrokeVariation
+    deriving Eq
+
+instance Show BStrokeVariation
+  where
+    show AnyStrokeVariation = "Any"
+    show NoFitStrokeVariation = "No Fit"
+    show GradualDiagonalStrokeVariation = "Gradual/Diagonal"
+    show GradualTransitionalStrokeVariation = "Gradual/Transitional"
+    show GradualVerticalStrokeVariation = "Gradual/Vertical"
+    show GradualHorizontalStrokeVariation = "Gradual/Horizontal"
+    show RapidVerticalStrokeVariation = "Rapid/Vertical"
+    show RapidHorizontalStrokeVariation = "Rapid/Horizontal"
+    show InstantVerticalStrokeVariation = "Instant/Vertical"
+
+instance Enum BStrokeVariation
+  where
+    fromEnum AnyStrokeVariation = 0
+    fromEnum NoFitStrokeVariation = 1
+    fromEnum GradualDiagonalStrokeVariation = 2
+    fromEnum GradualTransitionalStrokeVariation = 3
+    fromEnum GradualVerticalStrokeVariation = 4
+    fromEnum GradualHorizontalStrokeVariation = 5
+    fromEnum RapidVerticalStrokeVariation = 6
+    fromEnum RapidHorizontalStrokeVariation = 7
+    fromEnum InstantVerticalStrokeVariation = 8
+    toEnum 0 = AnyStrokeVariation
+    toEnum 1 = NoFitStrokeVariation
+    toEnum 2 = GradualDiagonalStrokeVariation
+    toEnum 3 = GradualTransitionalStrokeVariation
+    toEnum 4 = GradualVerticalStrokeVariation
+    toEnum 5 = GradualHorizontalStrokeVariation
+    toEnum 6 = RapidVerticalStrokeVariation
+    toEnum 7 = RapidHorizontalStrokeVariation
+    toEnum 8 = InstantVerticalStrokeVariation
+    toEnum _ = error "Unknown stroke variation"
+
+data BArmStyle
+    = AnyArmStyle
+    | NoFitArmStyle
+    | StraightArmsHorizontalArmStyle
+    | StraightArmsWedgeArmStyle
+    | StraightArmsVerticalArmStyle
+    | StraightArmsSingleSerifArmStyle
+    | StraightArmsDoubleSerifArmStyle
+    | NonStraightArmsHorizontalArmStyle
+    | NonStraightArmsWedgeArmStyle
+    | NonStraightArmsVerticalArmStyle
+    | NonStraightArmsSingleSerifArmStyle
+    | NonStraightArmsDoubleSerifArmStyle
+    deriving Eq
+
+instance Show BArmStyle
+  where
+    show AnyArmStyle = "Any"
+    show NoFitArmStyle = "No Fit"
+    show StraightArmsHorizontalArmStyle = "Straight Arms/Horizontal"
+    show StraightArmsWedgeArmStyle = "Straight Arms/Wedge"
+    show StraightArmsVerticalArmStyle = "Straight Arms/Vertical"
+    show StraightArmsSingleSerifArmStyle = "Straight Arms/Single Serif"
+    show StraightArmsDoubleSerifArmStyle = "Straight Arms/Double Serif"
+    show NonStraightArmsHorizontalArmStyle = "Non-Straight Arms/Horizontal"
+    show NonStraightArmsWedgeArmStyle = "Non-Straight Arms/Wedge"
+    show NonStraightArmsVerticalArmStyle = "Non-Straight Arms/Vertical"
+    show NonStraightArmsSingleSerifArmStyle = "Non-Straight Arms/Single Serif"
+    show NonStraightArmsDoubleSerifArmStyle = "Non-Straight Arms/Double Serif"
+
+instance Enum BArmStyle
+  where
+    fromEnum AnyArmStyle = 0
+    fromEnum NoFitArmStyle = 1
+    fromEnum StraightArmsHorizontalArmStyle = 2
+    fromEnum StraightArmsWedgeArmStyle = 3
+    fromEnum StraightArmsVerticalArmStyle = 4
+    fromEnum StraightArmsSingleSerifArmStyle = 5
+    fromEnum StraightArmsDoubleSerifArmStyle = 6
+    fromEnum NonStraightArmsHorizontalArmStyle = 7
+    fromEnum NonStraightArmsWedgeArmStyle = 8
+    fromEnum NonStraightArmsVerticalArmStyle = 9
+    fromEnum NonStraightArmsSingleSerifArmStyle = 10
+    fromEnum NonStraightArmsDoubleSerifArmStyle = 11
+    toEnum 0 = AnyArmStyle
+    toEnum 1 = NoFitArmStyle
+    toEnum 2 = StraightArmsHorizontalArmStyle
+    toEnum 3 = StraightArmsWedgeArmStyle
+    toEnum 4 = StraightArmsVerticalArmStyle
+    toEnum 5 = StraightArmsSingleSerifArmStyle
+    toEnum 6 = StraightArmsDoubleSerifArmStyle
+    toEnum 7 = NonStraightArmsHorizontalArmStyle
+    toEnum 8 = NonStraightArmsWedgeArmStyle
+    toEnum 9 = NonStraightArmsVerticalArmStyle
+    toEnum 10 = NonStraightArmsSingleSerifArmStyle
+    toEnum 11 = NonStraightArmsDoubleSerifArmStyle
+    toEnum _ = error "Unknown arm style"
+
+data BLetterform
+    = AnyLetterform
+    | NoFitLetterform
+    | NormalContactLetterform
+    | NormalWeightedLetterform
+    | NormalBoxedLetterform
+    | NormalFlattenedLetterform
+    | NormalRoundedLetterform
+    | NormalOffCenterLetterform
+    | NormalSquareLetterform
+    | ObliqueContactLetterform
+    | ObliqueWeightedLetterform
+    | ObliqueBoxedLetterform
+    | ObliqueFlattenedLetterform
+    | ObliqueRoundedLetterform
+    | ObliqueOffCenterLetterform
+    | ObliqueSquareLetterform
+    deriving Eq
+
+instance Show BLetterform
+  where
+    show AnyLetterform = "Any"
+    show NoFitLetterform = "No Fit"
+    show NormalContactLetterform = "Normal/Contact"
+    show NormalWeightedLetterform = "Normal/Weighted"
+    show NormalBoxedLetterform = "Normal/Boxed"
+    show NormalFlattenedLetterform = "Normal/Flattened"
+    show NormalRoundedLetterform = "Normal/Rounded"
+    show NormalOffCenterLetterform = "Normal/Off Center"
+    show NormalSquareLetterform = "Normal/Square"
+    show ObliqueContactLetterform = "Oblique/Contact"
+    show ObliqueWeightedLetterform = "Oblique/Weighted"
+    show ObliqueBoxedLetterform = "Oblique/Boxed"
+    show ObliqueFlattenedLetterform = "Oblique/Flattened"
+    show ObliqueRoundedLetterform = "Oblique/Rounded"
+    show ObliqueOffCenterLetterform = "Oblique/Off Center"
+    show ObliqueSquareLetterform = "Oblique/Square"
+
+instance Enum BLetterform
+  where
+    fromEnum AnyLetterform = 0
+    fromEnum NoFitLetterform = 1
+    fromEnum NormalContactLetterform = 2
+    fromEnum NormalWeightedLetterform = 3
+    fromEnum NormalBoxedLetterform = 4
+    fromEnum NormalFlattenedLetterform = 5
+    fromEnum NormalRoundedLetterform = 6
+    fromEnum NormalOffCenterLetterform = 7
+    fromEnum NormalSquareLetterform = 8
+    fromEnum ObliqueContactLetterform = 9
+    fromEnum ObliqueWeightedLetterform = 10
+    fromEnum ObliqueBoxedLetterform = 11
+    fromEnum ObliqueFlattenedLetterform = 12
+    fromEnum ObliqueRoundedLetterform = 13
+    fromEnum ObliqueOffCenterLetterform = 14
+    fromEnum ObliqueSquareLetterform = 15
+    toEnum 0 = AnyLetterform
+    toEnum 1 = NoFitLetterform
+    toEnum 2 = NormalContactLetterform
+    toEnum 3 = NormalWeightedLetterform
+    toEnum 4 = NormalBoxedLetterform
+    toEnum 5 = NormalFlattenedLetterform
+    toEnum 6 = NormalRoundedLetterform
+    toEnum 7 = NormalOffCenterLetterform
+    toEnum 8 = NormalSquareLetterform
+    toEnum 9 = ObliqueContactLetterform
+    toEnum 10 = ObliqueWeightedLetterform
+    toEnum 11 = ObliqueBoxedLetterform
+    toEnum 12 = ObliqueFlattenedLetterform
+    toEnum 13 = ObliqueRoundedLetterform
+    toEnum 14 = ObliqueOffCenterLetterform
+    toEnum 15 = ObliqueSquareLetterform
+    toEnum _ = error "Unknown letterform"
+
+data BMidline
+    = AnyMidline
+    | NoFitMidline
+    | StandardTrimmedMidline
+    | StandardPointedMidline
+    | StandardSerifedMidline
+    | HighTrimmedMidline
+    | HighPointedMidline
+    | HighSerifedMidline
+    | ConstantTrimmedMidline
+    | ConstantPointedMidline
+    | ConstantSerifedMidline
+    | LowTrimmedMidline
+    | LowPointedMidline
+    | LowSerifedMidline
+    deriving Eq
+
+instance Show BMidline
+  where
+    show AnyMidline = "Any"
+    show NoFitMidline = "No Fit"
+    show StandardTrimmedMidline = "Standard/Trimmed"
+    show StandardPointedMidline = "Standard/Pointed"
+    show StandardSerifedMidline = "Standard/Serifed"
+    show HighTrimmedMidline = "High/Trimmed"
+    show HighPointedMidline = "High/Pointed"
+    show HighSerifedMidline = "High/Serifed"
+    show ConstantTrimmedMidline = "Constant/Trimmed"
+    show ConstantPointedMidline = "Constant/Pointed"
+    show ConstantSerifedMidline = "Constant/Serifed"
+    show LowTrimmedMidline = "Low/Trimmed"
+    show LowPointedMidline = "Low/Pointed"
+    show LowSerifedMidline = "Low/Serifed"
+
+instance Enum BMidline
+  where
+    fromEnum AnyMidline = 0
+    fromEnum NoFitMidline = 1
+    fromEnum StandardTrimmedMidline = 2
+    fromEnum StandardPointedMidline = 3
+    fromEnum StandardSerifedMidline = 4
+    fromEnum HighTrimmedMidline = 5
+    fromEnum HighPointedMidline = 6
+    fromEnum HighSerifedMidline = 7
+    fromEnum ConstantTrimmedMidline = 8
+    fromEnum ConstantPointedMidline = 9
+    fromEnum ConstantSerifedMidline = 10
+    fromEnum LowTrimmedMidline = 11
+    fromEnum LowPointedMidline = 12
+    fromEnum LowSerifedMidline = 13
+    toEnum 0 = AnyMidline
+    toEnum 1 = NoFitMidline
+    toEnum 2 = StandardTrimmedMidline
+    toEnum 3 = StandardPointedMidline
+    toEnum 4 = StandardSerifedMidline
+    toEnum 5 = HighTrimmedMidline
+    toEnum 6 = HighPointedMidline
+    toEnum 7 = HighSerifedMidline
+    toEnum 8 = ConstantTrimmedMidline
+    toEnum 9 = ConstantPointedMidline
+    toEnum 10 = ConstantSerifedMidline
+    toEnum 11 = LowTrimmedMidline
+    toEnum 12 = LowPointedMidline
+    toEnum 13 = LowSerifedMidline
+    toEnum _ = error "Unknown midline"
+
+data BXHeight
+    = AnyXHeight
+    | NoFitXHeight
+    | ConstantSmallXHeight
+    | ConstantStandardXHeight
+    | ConstantLargeXHeight
+    | DuckingSmallXHeight
+    | DuckingStandardXHeight
+    | DuckingLargeXHeight
+    deriving Eq
+
+instance Show BXHeight
+  where
+    show AnyXHeight = "Any"
+    show NoFitXHeight = "No Fit"
+    show ConstantSmallXHeight = "Constant/Small"
+    show ConstantStandardXHeight = "Constant/Standard"
+    show ConstantLargeXHeight = "Constant/Large"
+    show DuckingSmallXHeight = "Ducking/Small"
+    show DuckingStandardXHeight = "Ducking/Standard"
+    show DuckingLargeXHeight = "Ducking/Large"
+
+instance Enum BXHeight
+  where
+    fromEnum AnyXHeight = 0
+    fromEnum NoFitXHeight = 1
+    fromEnum ConstantSmallXHeight = 2
+    fromEnum ConstantStandardXHeight = 3
+    fromEnum ConstantLargeXHeight = 4
+    fromEnum DuckingSmallXHeight = 5
+    fromEnum DuckingStandardXHeight = 6
+    fromEnum DuckingLargeXHeight = 7
+    toEnum 0 = AnyXHeight
+    toEnum 1 = NoFitXHeight
+    toEnum 2 = ConstantSmallXHeight
+    toEnum 3 = ConstantStandardXHeight
+    toEnum 4 = ConstantLargeXHeight
+    toEnum 5 = DuckingSmallXHeight
+    toEnum 6 = DuckingStandardXHeight
+    toEnum 7 = DuckingLargeXHeight
+    toEnum _ = error "Unknown X height"
+
+-- * Kern table
+
+newtype KernHeader = KernHeader
+    { version :: Fixed32 -- ^ The version number of the kerning table (0x00010000 for the current version).
+    } deriving (Eq, Show)
+
+data KernSubtableHeader = KernSubtableHeader
+    -- | The length of this subtable in bytes, including this header.
+    { length :: Word32
+    -- | Circumstances under which this table is used.
+    , coverage :: [Coverage]
+    -- | The tuple index (used for variations fonts). This value specifies which
+    -- tuple this subtable covers.
+    , tupleIndex :: Word16
+    } deriving (Eq, Show)
+
+data Coverage
+    = KernVertical -- ^ Set if table has vertical kerning values.
+    | KernCrossStream -- ^ Set if table has cross-stream kerning values.
+    | KernVariation -- ^ Set if table has variation kerning values.
+    | KernUnusedBits -- ^ Set to 0.
+    | KernFormatMask -- ^ Set the format of this subtable (0-3 currently defined).
+    deriving (Eq, Show)
+
+data KernFormat0Pair = KernFormat0Pair
+    { left :: Word16 -- ^ The glyph index for the lefthand glyph in the kerning pair.
+    , right :: Word16 -- ^ The glyph index for the righthand glyph in the kerning pair.
+    -- | The kerning value in FUnits for the left and right pair in FUnits.
+    -- If this value is greater than zero, the glyphs are moved apart.
+    -- If this value is less than zero, the glyphs are moved together.
+    , value :: Int16
+    } deriving (Eq, Show)
+
+data KernFormat0Table = KernFormat0Table
+    -- | The largest power of two less than or equal to the value of nPairs,
+    -- multiplied by the size in bytes of an entry in the subtable.
+    { searchRange :: Word16
+    -- | This is calculated as log2 of the largest power of two less than or
+    -- equal to the value of nPairs. This value indicates how many iterations of
+    -- the search loop have to be made. For example, in a list of eight items,
+    -- there would be three iterations of the loop.
+    , entrySelector :: Word16
+    -- | The value of nPairs minus the largest power of two less than or equal
+    -- to nPairs. This is multiplied by the size in bytes of an entry in the
+    -- table.
+    , rangeShift :: Word16
+    , pairs :: [KernFormat0Pair]
+    } deriving (Eq, Show)
+
+-- | Kern subtable format 1 header.
+data StateHeader = StateHeader
+    { stateSize :: Word16 -- ^ Number of classes defined for this table.
+    -- | Offset from the beginning of the state table to the beginning of the
+    -- class subtable.
+    , classTableOffset :: Word16
+    -- | Offset from the beginning of the state table to the beginning of the
+    -- state array.
+    , stateArrayOffset :: Word16
+    -- | Offset from the beginning of the state table to the beginning of the
+    -- entry subtable.
+    , entryTableOffset :: Word16
+    -- | Offset from the beginning of the state table to the beginning of the
+    -- state table values.
+    , valueOffset :: Word16
+    } deriving (Eq, Show)
+
+data StateEntry = StateEntry
+    { newState :: Word16
+    , flags :: Word16
+    } deriving (Eq, Show)
+
+data KernFormat1Table = KernFormat1Table
+    { stateHeader :: StateHeader
+    , firstGlyph :: Word16
+    , classArray :: ByteString
+    , stateArray :: ByteString
+    , entries :: [StateEntry]
+    } deriving (Eq, Show)
+
+data SimpleArrayHeader = SimpleArrayHeader
+    { rowWidth :: Word16 -- ^ The width, in bytes, of a row in the subtable.
+    -- | Offset from beginning of this subtable to the left-hand offset table.
+    , leftOffsetTable :: Word16
+    -- | Offset from beginning of this subtable to right-hand offset table.
+    , rightOffsetTable :: Word16
+    -- | Offset from beginning of this subtable to the start of the kerning
+    -- array.
+    , array :: Word16
+    } deriving (Eq, Show)
+
+data ClassTableHeader = ClassTableHeader
+    { firstGlyph -- ^ First glyph in class range.
+    -- | The offsets array for all of the glyphs in the range.
+    , offsets :: [Word16]
+    } deriving (Eq, Show)
+
+data KernFormat2Table = KernFormat2Table
+   { simpleArrayHeader :: SimpleArrayHeader
+   , 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
diff --git a/lib/Graphics/Fountainhead/Type.hs b/lib/Graphics/Fountainhead/Type.hs
new file mode 100644
index 0000000..e809d9c
--- /dev/null
+++ b/lib/Graphics/Fountainhead/Type.hs
@@ -0,0 +1,41 @@
+{- 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)
+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
+
+fixed2Double :: F2Dot14 -> Double
+fixed2Double (F2Dot14 fixed) =
+    let mantissa = realToFrac (fixed .>>. 14)
+        fraction = realToFrac (fixed .&. 0x3fff) / 16384.0
+     in mantissa + fraction
author	Eugen Wissner <belka@caraus.de>	2024-02-03 11:58:47 +0100
committer	Eugen Wissner <belka@caraus.de>	2024-02-03 11:58:47 +0100
commit	a34b46e1b553623d5dc385fc8e235df808fbadb2 (patch)
tree	7035a9625532bf6f7f41962c4352ac2367d065f3 /lib
parent	34d3ece99e438e5e81f4df6ca7a36de307e41b3e (diff)
download	fountainhead-a34b46e1b553623d5dc385fc8e235df808fbadb2.tar.gz