fountainhead/src/Graphics/Fountainhead/Dumper.hs

693 lines
36 KiB
Haskell

{- 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
, 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(..)
, LongHorMetric(..)
, LocaTable(..)
, NameRecord (..)
, NameTable(..)
, IndexToLocFormat(..)
, OpenMaxpTable(..)
, MaxpTable(..)
, TrueMaxpTable(..)
, nameStringOffset
, Os2BaseFields(..)
, Os2MicrosoftFields(..)
, Os2Version1Fields(..)
, Os2Version4Fields(..)
, Os2Version5Fields(..)
, Os2Table(..)
, Panose(..)
, CVTable(..)
)
import qualified Text.Megaparsec as Megaparsec
import Graphics.Fountainhead.Parser
( fontDirectoryP
, parseTable
, cmapTableP
, headTableP
, hheaTableP
, hmtxTableP
, gaspTableP
, locaTableP
, maxpTableP
, nameTableP
, os2TableP
, postTableP, cvTableP
)
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
} 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
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 = RequiredTables
<$> findRequired "hhea" hheaTableP
<*> findRequired "head" headTableP
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 $ dumpLoca
<$> parseTable tableEntry (locaTableP $ getField @"indexToLocFormat" headTable) processedState
"maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
"name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
"post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
"OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
"cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
"gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState
_ -> 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