path: root/src/Graphics/Fountainhead/Parser.hs

{- 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
    , 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(..), 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

-- * 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

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

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 (coordinateP xFlagPair) mempty flags'
    ys <- Vector.foldM (coordinateP yFlagPair) mempty flags'
    pure $ SimpleGlyphDefinition
        { endPtsOfContours = endPtsOfContours'
        , instructions = instructions'
        , coordinates = mkCoordinate <$> Vector.zip3 xs ys flags'
        }
  where
    mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve
    xFlagPair :: OutlineFlag -> (Bool, Bool)
    xFlagPair OutlineFlag{ xShortVector, thisXIsSame } =
        (xShortVector, thisXIsSame)
    yFlagPair :: OutlineFlag -> (Bool, Bool)
    yFlagPair OutlineFlag{ yShortVector, thisYIsSame } =
        (yShortVector, thisYIsSame)
    coordinateP
        :: (OutlineFlag -> (Bool, Bool))
        -> Vector Int16
        -> OutlineFlag
        -> Parser (Vector Int16)
    coordinateP get accumulator first =
        case get first of
            (True, True) -> Vector.snoc accumulator . fromIntegral
                <$> Megaparsec.Binary.word8
                <?> "1 byte long positive coordinate"
            (True, False)
                -> Vector.snoc accumulator  . negate . fromIntegral
                <$> Megaparsec.Binary.word8
                <?> "1 byte long negative coordinate"
            (False, False) -> Vector.snoc accumulator
                <$> Megaparsec.Binary.int16be
                <?> "2 bytes long coordinate"
            (False, True) -> pure $ Vector.snoc accumulator 0
    flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag)
    flagsP remaining accumulator
        | remaining < 0 = pure accumulator
        | otherwise = do
            flag <- Megaparsec.Binary.word8 <?> "outline flags"
            let flag' = OutlineFlag
                    { onCurve = testBit flag 0
                    , xShortVector = testBit flag 1
                    , yShortVector = testBit flag 2
                    , thisXIsSame = testBit flag 4
                    , thisYIsSame = testBit flag 5
                    }
            repeatN <- 
                if testBit flag 3
                then (1 +)
                    . fromIntegral
                    <$> Megaparsec.Binary.word8
                    <?> "flag repeat count"
                else pure 1
            flagsP (remaining - repeatN)
                $ accumulator <> Vector.replicate repeatN flag'

glyfTableP :: LocaTable -> Parser GlyfTable
glyfTableP locaTable
    | 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
    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
    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
    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
    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 = succ $ fromIntegral $ 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 (Megaparsec.ParseErrorBundle ByteString Void) 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