fountainhead/lib/Graphics/Fountainhead/Dumper.hs

861 lines
45 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
, dumpGASP
, dumpGlyf
, dumpHead
, dumpHmtx
, dumpHhea
, dumpLoca
, dumpName
, dumpMaxp
, dumpOs2
, dumpPost
, dumpTable
, dumpTables
, dumpOffsetTable
) where
import qualified Data.ByteString as ByteString
import Data.Int (Int64, Int16)
import Data.Word (Word8, Word16, Word32)
import qualified Data.IntMap as IntMap
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import qualified Data.Text.Lazy.Builder.RealFloat as Text.Builder
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import GHC.Records (HasField(..))
import Graphics.Fountainhead.TrueType
( CmapTable(..)
, CompoundGlyphDefinition(..)
, ComponentGlyphPartDescription(..)
, FontDirectory(..)
, FontDirectionHint(..)
, GASPRange(..)
, GASPTable(..)
, GlyphArgument(..)
, HeadTable(..)
, HheaTable(..)
, HmtxTable(..)
, OffsetSubtable(..)
, PostHeader(..)
, PostSubtable(..)
, PostFormat2Table(..)
, PostTable(..)
, TableDirectory(..)
, CmapEncoding(..)
, CmapSubtable(..)
, CmapFormat4Table(..)
, FontStyle(..)
, GlyphArgument(..)
, GlyphCoordinate(..)
, GlyphDefinition(..)
, GlyphDescription(..)
, GlyfTable(..)
, LongHorMetric(..)
, LocaTable(..)
, NameRecord (..)
, NameTable(..)
, IndexToLocFormat(..)
, OpenMaxpTable(..)
, MaxpTable(..)
, TrueMaxpTable(..)
, nameStringOffset
, Os2BaseFields(..)
, Os2MicrosoftFields(..)
, Os2Version1Fields(..)
, Os2Version4Fields(..)
, Os2Version5Fields(..)
, Os2Table(..)
, Panose(..)
, SimpleGlyphDefinition(..)
, CVTable(..)
, OutlineFlag(..)
, ComponentGlyphFlags(..)
, GlyphTransformationOption(..)
, findTableByTag
)
import qualified Text.Megaparsec as Megaparsec
import Graphics.Fountainhead.Parser
( ParseErrorBundle
, ParseState
, parseTable
, cmapTableP
, headTableP
, hheaTableP
, hmtxTableP
, gaspTableP
, locaTableP
, maxpTableP
, nameTableP
, os2TableP
, postTableP
, cvTableP
, glyfTableP
)
import Graphics.Fountainhead.Type
( Fixed32(..)
, succIntegral
, ttfEpoch
, fixed2Double
)
import Data.Foldable (Foldable(..))
import Data.Maybe (fromMaybe, catMaybes)
import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
import Data.Bits (Bits(..), (.>>.))
import Data.Bifunctor (Bifunctor(first))
import Data.List (intersperse)
import Prelude hiding (repeat)
data DumpError
= DumpParseError ParseErrorBundle
| DumpRequiredTableMissingError String
| DumpRequestedTableMissingError String
deriving Eq
instance Show DumpError
where
show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
show (DumpRequiredTableMissingError tableName) =
"Required table " <> tableName <> " is missing."
show (DumpRequestedTableMissingError tableName) =
"Requested table " <> tableName <> " is missing."
data RequiredTables = RequiredTables
{ hheaTable :: HheaTable
, headTable :: HeadTable
, locaTable :: LocaTable
} deriving (Eq, Show)
newlineBuilder :: Text.Builder.Builder
newlineBuilder = Text.Builder.singleton '\n'
paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
paddedHexadecimal = ("0x" <>)
. Text.Builder.fromLazyText
. 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
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 .&. 0xffff)
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" <> newlineBuilder
<> 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 italicAngle <> newlineBuilder
<> " underlinePosition: " <> Text.Builder.decimal underlinePosition <> newlineBuilder
<> " underlineThichness: " <> Text.Builder.decimal underlineThickness <> newlineBuilder
<> " isFixedPitch: " <> dNumber isFixedPitch <> newlineBuilder
<> " minMemType42: " <> dNumber minMemType42 <> newlineBuilder
<> " maxMemType42: " <> dNumber maxMemType42 <> newlineBuilder
<> " minMemType1: " <> dNumber minMemType1 <> newlineBuilder
<> " maxMemType1: " <> dNumber maxMemType1 <> newlineBuilder
<> dumpPostSubtable
where
dNumber = (<> Text.Builder.singleton 'd') . Text.Builder.decimal
dumpPostSubtable = case postSubtable of
None -> "" -- Format 1 and 3 do not require a subtable.
PostFormat2 PostFormat2Table{..}
-> " Format 2.0: Non-Standard (for PostScript) TrueType Glyph Set." <> newlineBuilder
<> " numGlyphs: " <> Text.Builder.decimal (Prelude.length glyphNameIndex)
<> newlineBuilder <> fold (Vector.imap (dumpFormat2Pair names) glyphNameIndex)
PostFormat25 _ -> "Format 2.5"
PostFormat4 _ -> "Format 4.0"
dumpFormat2Pair names index glyphNameIndex'
= " Glyf " <> justifyNumber 3 index
<> " -> " <> glyphType names glyphNameIndex'
<> newlineBuilder
glyphType names glyphNameIndex'
| glyphNameIndex' >= 0
, glyphNameIndex' <= 257 = "Mac Glyph # " <> justifyNumber 3 glyphNameIndex'
| glyphNameIndex' >= 258
, glyphNameIndex' <= 32767 =
let nameIndex = fromIntegral $ glyphNameIndex' - 258
in "PSGlyph Name # " <> justifyNumber 3 (succ nameIndex) <> ", '"
<> Text.Builder.fromText (Text.decodeASCII (names Vector.! nameIndex))
<> Text.Builder.singleton '\''
| otherwise = "Reserved"
dumpCmap :: CmapTable -> Text.Builder.Builder
dumpCmap CmapTable{..}
= dumpCaption "'cmap' Table - Character to Glyph Index Mapping Table"
<> " 'cmap' version: " <> Text.Builder.decimal version <> newlineBuilder
<> " number of encodings: " <> Text.Builder.decimal encodingsLength <> newlineBuilder
<> " number of subtables: " <> Text.Builder.decimal (Prelude.length subtables) <> newlineBuilder
<> newlineBuilder
<> snd (foldr dumpCmapEncoding (pred encodingsLength, "") encodings) <> newlineBuilder
<> snd (foldr dumpCmapSubTable (pred subTablesLength, "") subtables) <> newlineBuilder
where
encodingsLength = Prelude.length encodings
subTablesLength = IntMap.size subtables
dumpCmapEncoding CmapEncoding{..} (index, accumulator) =
let findSubTableIndex = Text.Builder.decimal
. Prelude.length
. filter ((< offset) . fromIntegral)
. IntMap.keys
summary = "Encoding " <> Text.Builder.decimal index
<> ". PlatformID: " <> Text.Builder.decimal platformID <> newlineBuilder
<> " EcodingID: " <> Text.Builder.decimal platformSpecificID <> newlineBuilder
<> " SubTable: " <> findSubTableIndex subtables
<> ", Offset: " <> paddedHexadecimal offset <> newlineBuilder
in (pred index, summary <> newlineBuilder <> accumulator)
dumpCmapSubTable currentSubTable (index, accumulator) =
let contents = "SubTable " <> Text.Builder.decimal index
<> ". " <> dumpCmapSubTableFormat currentSubTable
in (pred index, contents <> accumulator)
dumpCmapSubTableFormat = \case
(CmapFormat0 _) -> "Format 0"
(CmapFormat2 _) -> "Format 2"
(CmapFormat4 CmapFormat4Table{..}) ->
let segCount = Vector.length startCode
dumpSegment' = dumpSegment segCount glyphIndexArray
in "Format 4 - Segment mapping to delta values\n\
\ Length: 994\n\
\ Version: 0\n\
\ segCount: "
<> Text.Builder.decimal segCount
<> newlineBuilder <> " searchRange: "
<> Text.Builder.decimal searchRange
<> newlineBuilder <> " entrySelector: "
<> Text.Builder.decimal entrySelector
<> newlineBuilder <> " rangeShift: "
<> Text.Builder.decimal (segCount * 2 - fromIntegral searchRange)
<> newlineBuilder
<> fold (Vector.izipWith4 (dumpSegmentSummary segCount) startCode endCode idDelta idRangeOffset)
<> " Number of glyphIndex "
<> Text.Builder.decimal (Vector.length glyphIndexArray) <> newlineBuilder
<> fold (Vector.imap dumpGlyphAtIndex glyphIndexArray)
<> fold (Vector.izipWith4 dumpSegment' startCode endCode idDelta idRangeOffset)
(CmapFormat6 _) -> "Format 6"
(CmapFormat8 _) -> "Format 8"
(CmapFormat10 _) -> "Format 10"
(CmapFormat12 _) -> "Format 12"
(CmapFormat13 _) -> "Format 13"
(CmapFormat14 _) -> "Format 14"
dumpSegment :: Int -> Vector Word16 -> Int -> Word16 -> Word16 -> Word16 -> Word16 -> Text.Builder.Builder
dumpSegment segCount glyphIndexArray' segmentIndex startCode' endCode' idDelta' idRangeOffset' =
let charRange = [startCode'..endCode']
dumpSegmentCharIndex' =
dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode'
in "Segment " <> Text.Builder.decimal segmentIndex <> ":\n"
<> foldMap dumpSegmentCharIndex' charRange
dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode' charCode =
let calculateGlyphIndex' =
calculateGlyphIndex charCode segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode'
in " Char 0x"
<> halfPaddedHexadecimal charCode <> " -> Index "
<> Text.Builder.decimal calculateGlyphIndex'
<> newlineBuilder
dumpSegmentSummary segCount index startCode' endCode' idDelta' idRangeOffset'
= " Seg " <> justifyNumber 5 index
<> " : St = " <> halfPaddedHexadecimal startCode'
<> ", En = " <> halfPaddedHexadecimal endCode'
<> ", D = " <> justifyNumber 6 idDelta'
<> ", RO = " <> justifyNumber 6 idRangeOffset'
<> ", gId# = " <> dumpGlyphId index segCount idRangeOffset'
<> newlineBuilder
dumpGlyphId segmentIndex segCount idRangeOffset'
= maybe "N/A" Text.Builder.decimal
$ calculateGlyphId segmentIndex segCount idRangeOffset'
calculateGlyphIndex :: Word16 -> Int -> Int -> Vector Word16 -> Word16 -> Word16 -> Word16 -> Int
calculateGlyphIndex c segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode' =
let defaultIndex = fromIntegral $ c + idDelta'
addOffset = fromIntegral
. fromMaybe 0
. (glyphIndexArray' Vector.!?)
. (+ fromIntegral (c - startCode'))
in maybe defaultIndex addOffset
$ calculateGlyphId segmentIndex segCount idRangeOffset'
calculateGlyphId segmentIndex segCount idRangeOffset'
| idRangeOffset' == 0 = Nothing
| otherwise = Just $ segmentIndex - segCount + (fromIntegral idRangeOffset' `div` 2)
dumpGlyphAtIndex index element = " glyphIdArray[" <> Text.Builder.decimal index <> "] = "
<> Text.Builder.decimal element <> newlineBuilder
dumpLoca :: LocaTable -> Text.Builder.Builder
dumpLoca table =
dumpCaption "'loca' Table - Index to Location"
<> go table
where
go (LongLocaTable elements) = dumpElements elements
go (ShortLocaTable elements) = dumpElements
$ (* 2)
. (fromIntegral :: Word16 -> Word32)
<$> elements
dumpElements elements =
case Vector.unsnoc elements of
Just (init', last')
-> foldMap dumpLocaLine (Vector.indexed init')
<> " Ended at " <> paddedHexadecimal last' <> newlineBuilder
Nothing -> mempty
dumpLocaLine :: Integral a => (Int, a) -> Text.Builder.Builder
dumpLocaLine (index, element)
= " Idx " <> justifyNumber 6 index
<> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder
dumpName :: NameTable -> Text.Builder.Builder
dumpName table'@NameTable{..} = dumpCaption "'name' Table - Naming Table"
<> " Format: " <> Text.Builder.decimal format <> newlineBuilder
<> " Number of Record: " <> Text.Builder.decimal (Prelude.length nameRecord) <> newlineBuilder
<> " Storage offset: " <> Text.Builder.decimal (nameStringOffset table') <> newlineBuilder
<> foldMap go (zip3 [0 :: Int ..] nameRecord variable)
where
go (index, NameRecord{ length = length', ..}, variable')
= "Name table " <> justifyNumber 3 index <> "."
<> " PlatformID: " <> Text.Builder.decimal platformID <> newlineBuilder
<> " EncodingID: " <> Text.Builder.decimal platformSpecificID <> newlineBuilder
<> " LanguageID: " <> Text.Builder.decimal languageID <> newlineBuilder
<> " NameID: " <> Text.Builder.decimal nameID <> newlineBuilder
<> " Length: " <> Text.Builder.decimal length' <> newlineBuilder
<> " Offset: " <> Text.Builder.decimal offset <> newlineBuilder
<> foldMap (" " <>) (dumpHexString $ ByteString.unpack variable')
dumpHexString :: [Word8] -> [Text.Builder.Builder]
dumpHexString byteCodes
| null byteCodes = [dumpHexLine " > " byteCodes]
| Prelude.length byteCodes < 10 = [dumpHexLine " > " byteCodes]
| otherwise = dumpHexLine " > " byteCodes
: dumpHexString (drop 10 byteCodes)
where
dumpHexLine separator variable' =
let firstTen = take 10 variable'
digits = fold $ intersperse (Text.Builder.singleton ' ') $ hexByte <$> firstTen
printables = foldMap printableByte firstTen
in digits
<> Text.Builder.fromText (Text.replicate (10 - Prelude.length firstTen) " ")
<> separator
<> printables
<> newlineBuilder
printableByte :: Word8 -> Text.Builder.Builder
printableByte code
| code >= 0x20
, code < 0x7f = Text.Builder.singleton $ toEnum $ fromIntegral code
| otherwise = Text.Builder.singleton '.'
hexByte :: Integral a => a -> Text.Builder.Builder
hexByte = Text.Builder.fromLazyText
. Text.Lazy.justifyRight 2 '0'
. Text.Builder.toLazyText
. Text.Builder.hexadecimal
dumpMaxp :: MaxpTable -> Text.Builder.Builder
dumpMaxp (TrueMaxp TrueMaxpTable{..})
= dumpCaption "'maxp' Table - Maximum Profile"
<> " 'maxp' version: " <> dumpFixed32 version <> newlineBuilder
<> " numGlyphs: " <> Text.Builder.decimal numGlyphs <> newlineBuilder
<> " maxPoints: " <> Text.Builder.decimal maxPoints <> newlineBuilder
<> " maxContours: " <> Text.Builder.decimal maxContours <> newlineBuilder
<> " maxCompositePoints: " <> Text.Builder.decimal maxComponentPoints <> newlineBuilder
<> " maxCompositeContours: " <> Text.Builder.decimal maxComponentContours <> newlineBuilder
<> " maxZones: " <> Text.Builder.decimal maxZones <> newlineBuilder
<> " maxTwilightPoints: " <> Text.Builder.decimal maxTwilightPoints <> newlineBuilder
<> " maxStorage: " <> Text.Builder.decimal maxStorage <> newlineBuilder
<> " maxFunctionDefs: " <> Text.Builder.decimal maxFunctionDefs <> newlineBuilder
<> " maxInstructionDefs: " <> Text.Builder.decimal maxInstructionDefs <> newlineBuilder
<> " maxStackElements: " <> Text.Builder.decimal maxStackElements <> newlineBuilder
<> " maxSizeOfInstructions: " <> Text.Builder.decimal maxSizeOfInstructions <> newlineBuilder
<> " maxComponentElements: " <> Text.Builder.decimal maxComponentElements <> newlineBuilder
<> " maxCompoenetDepth: " <> Text.Builder.decimal maxComponentDepth <> newlineBuilder
dumpMaxp (OpenMaxp OpenMaxpTable{..})
= dumpCaption "'maxp' Table - Maximum Profile"
<> " 'maxp' version: " <> dumpFixed32 version <> newlineBuilder <> newlineBuilder
<> " numGlyphs: " <> Text.Builder.decimal numGlyphs <> newlineBuilder
dumpGASP :: GASPTable -> Text.Builder.Builder
dumpGASP GASPTable{..} = dumpCaption "'gasp' Table - Grid-fitting And Scan-conversion Procedure"
<> "'gasp' version: " <> Text.Builder.decimal version <> newlineBuilder
<> "numRanges: " <> Text.Builder.decimal (Prelude.length gaspRange) <> newlineBuilder
<> foldMap dumpGASPRange (zip [0..] gaspRange)
where
dumpGASPRange :: (Int, GASPRange) -> Text.Builder.Builder
dumpGASPRange (index', GASPRange{..}) = newlineBuilder
<> " gasp Range " <> Text.Builder.decimal index' <> newlineBuilder
<> " rangeMaxPPEM: " <> Text.Builder.decimal rangeMaxPPEM <> newlineBuilder
<> " rangeGaspBehavior: 0x" <> halfPaddedHexadecimal rangeGaspBehavior <> newlineBuilder
dumpGlyf :: GlyfTable -> Text.Builder.Builder
dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
<> foldMap go (Vector.indexed glyfDescriptions)
where
go (glyphIndex, GlyphDescription{..})
= "Glyph " <> justifyNumber 6 glyphIndex <> Text.Builder.singleton '.' <> newlineBuilder
<> " numberOfContours: " <> Text.Builder.decimal numberOfContours <> newlineBuilder
<> " xMin: " <> Text.Builder.decimal xMin <> newlineBuilder
<> " yMin: " <> Text.Builder.decimal yMin <> newlineBuilder
<> " xMax: " <> Text.Builder.decimal xMax <> newlineBuilder
<> " yMax: " <> Text.Builder.decimal yMax <> newlineBuilder
<> newlineBuilder <> dumpGlyphDefinition definition <> newlineBuilder
dumpEndPoint (endPointIndex, endPoint)
= " " <> justifyNumber 2 endPointIndex
<> ": " <> Text.Builder.decimal endPoint <> newlineBuilder
dumpGlyphDefinition (SimpleGlyph SimpleGlyphDefinition{..})
= " EndPoints" <> newlineBuilder
<> " ---------" <> newlineBuilder
<> foldMap dumpEndPoint (Vector.indexed endPtsOfContours) <> newlineBuilder
<> " Length of Instructions: "
<> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
<> newlineBuilder <> " Flags" <> newlineBuilder
<> " -----" <> newlineBuilder
<> fst (Vector.foldl' foldFlag ("", 0) flags) <> newlineBuilder
<> " Coordinates" <> newlineBuilder
<> " -----------" <> newlineBuilder
<> fst (Vector.ifoldl' foldCoordinate mempty coordinates)
dumpGlyphDefinition (CompoundGlyph CompoundGlyphDefinition{..})
= foldMap (dumpCompoundGlyph $ Vector.length components) (Vector.indexed components)
<> newlineBuilder <> " Length of Instructions: "
<> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
dumpCompoundGlyph :: Int -> (Int, ComponentGlyphPartDescription) -> Text.Builder.Builder
dumpCompoundGlyph componentsLength (componentIndex, description) =
let moreComponents = succ componentIndex < componentsLength
compoundFlags = dumpCompoundFlags moreComponents description
ComponentGlyphPartDescription{..} = description
in " " <> Text.Builder.decimal componentIndex
<> ": Flags: 0x" <> compoundFlags <> newlineBuilder
<> " Glyf Index: " <> Text.Builder.decimal glyphIndex <> newlineBuilder
<> " X" <> dumpArgument argument1 <> newlineBuilder
<> " Y" <> dumpArgument argument2 <> newlineBuilder
<> dumpTransformationOption transformationOption
<> " Others: " <> dumpOtherFlags flags <> newlineBuilder
<> newlineBuilder -- TODO
dumpTransformationOption GlyphNoScale = ""
dumpTransformationOption (GlyphScale scale) =
" X,Y Scale: " <> Text.Builder.realFloat (fixed2Double scale) <> newlineBuilder
dumpTransformationOption (GlyphXyScale xScale yScale)
= " X Scale: " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder
<> " Y Scale: " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder
dumpTransformationOption (Glyph2By2Scale xScale scale01 scale10 yScale)
= " X Scale: " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder
<> " X,Y Scale: " <> Text.Builder.realFloat (fixed2Double scale01) <> newlineBuilder
<> " Y,X Scale: " <> Text.Builder.realFloat (fixed2Double scale10) <> newlineBuilder
<> " Y Scale: " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder
dumpOtherFlags ComponentGlyphFlags{..} =
let roundXyToGridText = if roundXyToGrid then "Round X,Y to Grid " else " "
useMyMetricsText = if useMyMetrics then "Use My Metrics " else " "
overlapCompoundText = if overlapCompound then "Overlap " else " "
in roundXyToGridText <> overlapCompoundText <> useMyMetricsText
dumpCompoundFlags :: Bool -> ComponentGlyphPartDescription -> Text.Builder.Builder
dumpCompoundFlags moreComponents ComponentGlyphPartDescription{..} =
let setBits = glyphArgumentBits argument1
<> componentFlagBits flags
<> transformationOptionBits transformationOption
setBits' = if moreComponents then 5 : setBits else setBits
in Text.Builder.hexadecimal
$ foldr (flip setBit) (zeroBits :: Word16) setBits'
dumpArgument (GlyphInt8Argument argument) =
" BOffset: " <> Text.Builder.decimal argument
dumpArgument (GlyphInt16Argument argument) =
" WOffset: " <> Text.Builder.decimal argument
dumpArgument (GlyphWord8Argument argument) =
" BPoint: " <> Text.Builder.decimal argument
dumpArgument (GlyphWord16Argument argument) =
" WPoint: " <> Text.Builder.decimal argument
glyphArgumentBits (GlyphInt16Argument _) = [0, 1]
glyphArgumentBits (GlyphWord16Argument _) = [0]
glyphArgumentBits (GlyphInt8Argument _) = [1]
glyphArgumentBits (GlyphWord8Argument _) = []
componentFlagBits ComponentGlyphFlags{..} = catMaybes
[ if roundXyToGrid then Just 2 else Nothing
, if weHaveInstructions then Just 8 else Nothing
, if useMyMetrics then Just 9 else Nothing
, if overlapCompound then Just 10 else Nothing
]
transformationOptionBits GlyphScale{} = [3]
transformationOptionBits GlyphXyScale{} = [6]
transformationOptionBits Glyph2By2Scale{} = [7]
transformationOptionBits GlyphNoScale = []
dumpFlag lineValue coordinateIndex
= " " <> justifyNumber 2 coordinateIndex <> lineValue
foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int)
foldFlag (accumulator, coordinateIndex) OutlineFlag{..} =
let lineValue = ": "
<> (if thisYIsSame then "YDual " else " ")
<> (if thisXIsSame then "XDual " else " ")
<> (if repeat > 0 then "Repeat " else " ")
<> (if yShortVector then "Y-Short " else " ")
<> (if xShortVector then "X-Short " else " ")
<> (if onCurve then "On" else "Off")
<> newlineBuilder
repeatN = succIntegral repeat
repeatedLines = fold
$ Vector.cons accumulator
$ dumpFlag lineValue
<$> Vector.enumFromN coordinateIndex repeatN
in (repeatedLines, coordinateIndex + repeatN)
foldCoordinate
:: (Text.Builder.Builder, GlyphCoordinate)
-> Int
-> GlyphCoordinate
-> (Text.Builder.Builder, GlyphCoordinate)
foldCoordinate (accumulator, absCoordinate) coordinateIndex relCoordinate =
let nextAbs = relCoordinate <> absCoordinate
newLine = " " <> justifyNumber 2 coordinateIndex
<> " Rel " <> dumpCoordinate relCoordinate
<> " -> Abs " <> dumpCoordinate nextAbs
<> newlineBuilder
in (accumulator <> newLine, nextAbs)
dumpCoordinate GlyphCoordinate{..}
= "(" <> justifyNumber 7 coordinateX <> ", "
<> justifyNumber 7 coordinateY <> ")"
dumpTable
:: String
-> ParseState
-> FontDirectory
-> Either DumpError Text.Builder.Builder
dumpTable needle processedState fontDirectory
| Just neededTable <- findTableByTag needle fontDirectory
= parseRequired processedState fontDirectory
>>= maybe (pure mempty) (first DumpParseError)
. dumpSubTable processedState neededTable
| otherwise = Left $ DumpRequestedTableMissingError needle
dumpTables
:: ParseState
-> FontDirectory
-> Either DumpError Text.Builder.Builder
dumpTables processedState directory@FontDirectory{..}
= parseRequired processedState directory >>= traverseDirectory
where
traverseDirectory parsedRequired =
let initial = Right $ dumpOffsetTable directory
in foldl' (go parsedRequired) initial tableDirectory
go _ (Left accumulator) _ = Left accumulator
go parsedRequired (Right accumulator) tableEntry
= maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
$ dumpSubTable processedState tableEntry parsedRequired
concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
<$> builderDump
parseRequired :: ParseState -> FontDirectory -> Either DumpError RequiredTables
parseRequired processedState fontDirectory = do
requiredHhea <- findRequired "hhea" hheaTableP
requiredHead@HeadTable{ indexToLocFormat } <-
findRequired "head" headTableP
requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
pure $ RequiredTables
{ hheaTable = requiredHhea
, headTable = requiredHead
, locaTable = requiredLoca
}
where
findRequired tableName parser =
let missingError = Left $ DumpRequiredTableMissingError tableName
parseFound tableEntry = parseTable tableEntry parser processedState
in maybe missingError (first DumpParseError . parseFound)
$ findTableByTag tableName fontDirectory
dumpSubTable
:: ParseState
-> TableDirectory
-> RequiredTables
-> Maybe (Either ParseErrorBundle Text.Builder.Builder)
dumpSubTable processedState tableEntry RequiredTables{..} =
case getField @"tag" tableEntry of
"cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
"head" -> Just $ Right $ dumpHead headTable
"hhea" -> Just $ Right $ dumpHhea hheaTable
"hmtx" -> Just $ dumpHmtx
<$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
"loca" -> Just $ 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