fountainhead/src/Graphics/Fountainhead/Dumper.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 OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}

-- | Outputs information about a font as text.
module Graphics.Fountainhead.Dumper
    ( DumpError(..)
    , dumpCmap
    , 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 Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Void
import GHC.Records (HasField(..))
import Graphics.Fountainhead.TrueType
    ( CmapTable(..)
    , FontDirectory(..)
    , FontDirectionHint(..)
    , GASPRange(..)
    , GASPTable(..)
    , HeadTable(..)
    , HheaTable(..)
    , HmtxTable(..)
    , OffsetSubtable(..)
    , PostHeader(..)
    , PostSubtable(..)
    , PostFormat2Table(..)
    , PostTable(..)
    , TableDirectory(..)
    , CmapEncoding(..)
    , CmapSubtable(..)
    , CmapFormat4Table(..)
    , FontStyle(..)
    , GlyphCoordinate(..)
    , GlyphDefinition(..)
    , GlyphDescription(..)
    , GlyfTable(..)
    , LongHorMetric(..)
    , LocaTable(..)
    , NameRecord (..)
    , NameTable(..)
    , IndexToLocFormat(..)
    , OpenMaxpTable(..)
    , MaxpTable(..)
    , TrueMaxpTable(..)
    , nameStringOffset
    , Os2BaseFields(..)
    , Os2MicrosoftFields(..)
    , Os2Version1Fields(..)
    , Os2Version4Fields(..)
    , Os2Version5Fields(..)
    , Os2Table(..)
    , Panose(..)
    , SimpleGlyphDefinition(..)
    , CVTable(..)
    )
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(..), ttfEpoch)
import Data.Foldable (Foldable(..), find)
import Data.Maybe (fromMaybe)
import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
import Data.Bits (Bits(..), (.>>.))
import Data.Bifunctor (Bifunctor(first))
import Data.List (intersperse)

data DumpError
    = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
    | DumpRequiredTableMissingError String

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
        <> "         Flags" <> newlineBuilder
        <> "         -----" <> newlineBuilder
        <> foldMap dumpFlag (Vector.indexed coordinates) <>  newlineBuilder <> newlineBuilder
    dumpGlyphDefinition _ = ""
    dumpFlag (coordinateIndex, GlyphCoordinate{..})
        = "         " <> justifyNumber 2 coordinateIndex <> ": "
        <> Text.Builder.decimal coordinateX <> " " <> Text.Builder.decimal coordinateY <> " "
        <> (if onCurve then "On" else "Off")
        <> newlineBuilder

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