diff options
Diffstat (limited to 'lib/Graphics/Fountainhead/Dumper.hs')
| -rw-r--r-- | lib/Graphics/Fountainhead/Dumper.hs | 854 |
1 files changed, 854 insertions, 0 deletions
diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs new file mode 100644 index 0000000..bbb17c2 --- /dev/null +++ b/lib/Graphics/Fountainhead/Dumper.hs @@ -0,0 +1,854 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +-- | Outputs information about a font as text. +module Graphics.Fountainhead.Dumper + ( DumpError(..) + , dumpCmap + , dumpGlyf + , dumpHead + , dumpHmtx + , dumpHhea + , dumpLoca + , dumpName + , dumpMaxp + , dumpOs2 + , dumpPost + , dumpTables + , dumpTrueType + , dumpOffsetTable + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import Data.Int (Int64, Int16) +import Data.Word (Word8, Word16, Word32) +import qualified Data.IntMap as IntMap +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Text.Lazy.Builder.Int as Text.Builder +import qualified Data.Text.Lazy.Builder.RealFloat as Text.Builder +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Void +import GHC.Records (HasField(..)) +import Graphics.Fountainhead.TrueType + ( CmapTable(..) + , CompoundGlyphDefinition(..) + , ComponentGlyphPartDescription(..) + , FontDirectory(..) + , FontDirectionHint(..) + , GASPRange(..) + , GASPTable(..) + , GlyphArgument(..) + , HeadTable(..) + , HheaTable(..) + , HmtxTable(..) + , OffsetSubtable(..) + , PostHeader(..) + , PostSubtable(..) + , PostFormat2Table(..) + , PostTable(..) + , TableDirectory(..) + , CmapEncoding(..) + , CmapSubtable(..) + , CmapFormat4Table(..) + , FontStyle(..) + , GlyphArgument(..) + , GlyphCoordinate(..) + , GlyphDefinition(..) + , GlyphDescription(..) + , GlyfTable(..) + , LongHorMetric(..) + , LocaTable(..) + , NameRecord (..) + , NameTable(..) + , IndexToLocFormat(..) + , OpenMaxpTable(..) + , MaxpTable(..) + , TrueMaxpTable(..) + , nameStringOffset + , Os2BaseFields(..) + , Os2MicrosoftFields(..) + , Os2Version1Fields(..) + , Os2Version4Fields(..) + , Os2Version5Fields(..) + , Os2Table(..) + , Panose(..) + , SimpleGlyphDefinition(..) + , CVTable(..) + , OutlineFlag(..) + , ComponentGlyphFlags(..) + , GlyphTransformationOption(..) + ) +import qualified Text.Megaparsec as Megaparsec +import Graphics.Fountainhead.Parser + ( fontDirectoryP + , parseTable + , cmapTableP + , headTableP + , hheaTableP + , hmtxTableP + , gaspTableP + , locaTableP + , maxpTableP + , nameTableP + , os2TableP + , postTableP + , cvTableP + , glyfTableP + ) +import Graphics.Fountainhead.Type + ( Fixed32(..) + , succIntegral + , ttfEpoch + , fixed2Double + ) +import Data.Foldable (Foldable(..), find) +import Data.Maybe (fromMaybe, catMaybes) +import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight) +import Data.Bits (Bits(..), (.>>.)) +import Data.Bifunctor (Bifunctor(first)) +import Data.List (intersperse) +import Prelude hiding (repeat) + +data DumpError + = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) + | DumpRequiredTableMissingError String + deriving Eq + +instance Show DumpError + where + show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle + show (DumpRequiredTableMissingError tableName) = + "Required table " <> tableName <> " is missing." + +data RequiredTables = RequiredTables + { hheaTable :: HheaTable + , headTable :: HeadTable + , locaTable :: LocaTable + } deriving (Eq, Show) + +paddedHexadecimal :: Integral a => a -> Text.Builder.Builder +paddedHexadecimal = ("0x" <>) + . Text.Builder.fromLazyText + . Text.Lazy.justifyRight 8 '0' + . Text.Builder.toLazyText + . Text.Builder.hexadecimal + +halfPaddedHexadecimal :: Integral a => a -> Text.Builder.Builder +halfPaddedHexadecimal = Text.Builder.fromLazyText + . Text.Lazy.justifyRight 4 '0' + . Text.Builder.toLazyText + . Text.Builder.hexadecimal + +justifyNumber :: Integral a => Int64 -> a -> Text.Builder.Builder +justifyNumber count = Text.Builder.fromLazyText + . Text.Lazy.justifyRight count ' ' + . Text.Builder.toLazyText + . Text.Builder.decimal + +newlineBuilder :: Text.Builder.Builder +newlineBuilder = Text.Builder.singleton '\n' + +dumpCaption :: String -> Text.Builder.Builder +dumpCaption headline = Text.Builder.fromString headline + <> newlineBuilder + <> Text.Builder.fromLazyText (Text.Lazy.replicate headlineLength "-") + <> newlineBuilder + where + headlineLength = fromIntegral $ Prelude.length headline + +dumpOffsetTable :: FontDirectory -> Text.Builder.Builder +dumpOffsetTable directory + = dumpCaption "Offset Table" + <> " sfnt version: 1.0\n number of tables: " + <> Text.Builder.decimal (numTables $ offsetSubtable directory) + <> newlineBuilder + <> dumpOffsetSummary (tableDirectory directory) + where + dumpOffsetSummary = mconcat . fmap dumpOffsetRow . zip [0 :: Int ..] + dumpOffsetRow (index, table) = justifyNumber 4 index + <> ". '" + <> Text.Builder.fromText (Text.decodeASCII $ tag table) + <> "' - checksum = " + <> paddedHexadecimal (getField @"checkSum" table) + <> ", offset = " + <> paddedHexadecimal (getField @"offset" table) + <> ", len = " + <> justifyNumber 9 (getField @"length" table) + <> newlineBuilder + +dumpFixed32 :: Fixed32 -> Text.Builder.Builder +dumpFixed32 (Fixed32 word) + = Text.Builder.decimal (shiftR word 16) + <> Text.Builder.singleton '.' + <> Text.Builder.decimal (word .&. 0xff00) + +dumpHmtx :: HmtxTable -> Text.Builder.Builder +dumpHmtx HmtxTable{..} = + let caption = dumpCaption "'hmtx' Table - Horizontal Metrics" + lastAccumulator = foldl' dumpHMetric (0 :: Int, caption) hMetrics + in snd $ foldl' dumpLeftSideBear lastAccumulator leftSideBearing + where + dumpLeftSideBear (index, accumulator) leftSideBearing' = + let withNewLine = dumpIndex index <> ". LSbear: " + <> justifyNumber 4 leftSideBearing' <> newlineBuilder + in (succ index, accumulator <> withNewLine) + dumpHMetric (index, accumulator) metric = + let LongHorMetric{ leftSideBearing = leftSideBearing', ..} = metric + withNewLine = dumpIndex index <> ". advWid: " + <> justifyNumber 4 advanceWidth <> ", LSBear: " + <> justifyNumber 4 leftSideBearing' <> newlineBuilder + in (succ index, accumulator <> withNewLine) + dumpIndex = justifyNumber 12 + +dumpHhea :: HheaTable -> Text.Builder.Builder +dumpHhea HheaTable{..} + = dumpCaption "'hhea' Table - Horizontal Header" + <> " 'hhea' version: " <> dumpFixed32 version <> newlineBuilder + <> " yAscender: " <> Text.Builder.decimal ascent <> newlineBuilder + <> " yDescender: " <> Text.Builder.decimal descent <> newlineBuilder + <> " yLineGap: " <> Text.Builder.decimal lineGap <> newlineBuilder + <> " advanceWidthMax: " <> Text.Builder.decimal advanceWidthMax <> newlineBuilder + <> " minLeftSideBearing: " <> Text.Builder.decimal minLeftSideBearing <> newlineBuilder + <> " minRightSideBearing: " <> Text.Builder.decimal minRightSideBearing <> newlineBuilder + <> " xMaxExtent: " <> Text.Builder.decimal xMaxExtent <> newlineBuilder + <> " caretSlopeRise: " <> Text.Builder.decimal caretSlopeRise <> newlineBuilder + <> " caretSlopeRun: " <> Text.Builder.decimal caretSlopeRun <> newlineBuilder + <> " reserved0: 0" <> newlineBuilder + <> " reserved1: 0" <> newlineBuilder + <> " reserved2: 0" <> newlineBuilder + <> " reserved3: 0" <> newlineBuilder + <> " reserved4: 0" <> newlineBuilder + <> " metricDataFormat: " <> Text.Builder.decimal metricDataFormat <> newlineBuilder + <> " numberOfHMetrics: " <> Text.Builder.decimal numOfLongHorMetrics <> newlineBuilder + +dumpHead :: HeadTable -> Text.Builder.Builder +dumpHead HeadTable{..} + = dumpCaption "'head' Table - Font Header" + <> " head version: " <> dumpFixed32 version <> newlineBuilder + <> " fontRevision: " <> dumpFixed32 fontRevision <> newlineBuilder + <> " checkSumAdjustment: " <> paddedHexadecimal checkSumAdjustment <> newlineBuilder + <> " magicNumber: " <> paddedHexadecimal magicNumber <> newlineBuilder + <> " flags: 0x" <> halfPaddedHexadecimal flags <> newlineBuilder + <> " unitsPerEm: " <> Text.Builder.decimal unitsPerEm <> newlineBuilder + <> " created: " <> "0x" <> longDateTime created <> newlineBuilder + <> " modified: " <> "0x" <> longDateTime modified <> newlineBuilder + <> " xMin: " <> Text.Builder.decimal xMin <> newlineBuilder + <> " yMin: " <> Text.Builder.decimal yMin <> newlineBuilder + <> " xMax: " <> Text.Builder.decimal xMax <> newlineBuilder + <> " yMax: " <> Text.Builder.decimal yMax <> newlineBuilder + <> " macStyle bits: " <> "0x" <> dumpFontStyle macStyle <> newlineBuilder + <> " lowestRecPPEM " <> Text.Builder.decimal lowestRecPPEM <> newlineBuilder + <> " fontDirectionHint " <> dumpFontDirectionHint fontDirectionHint <> newlineBuilder + <> " indexToLocFormat " <> dumpIndexToLocFormat indexToLocFormat <> newlineBuilder + <> " glyphDataFormat " <> Text.Builder.decimal glyphDataFormat <> newlineBuilder + +dumpIndexToLocFormat :: IndexToLocFormat -> Text.Builder.Builder +dumpIndexToLocFormat ShortOffsetIndexToLocFormat = "0" +dumpIndexToLocFormat LongOffsetIndexToLocFormat = "1" + +dumpFontDirectionHint :: FontDirectionHint -> Text.Builder.Builder +dumpFontDirectionHint = \case + MixedDirectionalGlyphs -> "0" + StronglyLeftToRightGlyphs -> "1" + LeftToRightGlyphsWithNeutrals -> "2" + StronglyRightToLeftGlyphs -> "-1" + RightToLeftGlyphsWithNeutrals -> "-2" + +dumpFontStyle :: FontStyle -> Text.Builder.Builder +dumpFontStyle FontStyle{..} = halfPaddedHexadecimal + $ foldr (go . fst) (zeroBits :: Int) + $ filter snd + $ zip [0..] [bold, italic, underline, outline, shadow, condensed, extended] + where + go bitNumber accumulator = setBit accumulator bitNumber + +longDateTime :: LocalTime -> Text.Builder.Builder +longDateTime localTime = Text.Builder.fromLazyText + $ Text.Lazy.justifyRight 16 '0' + $ Text.Builder.toLazyText + $ Text.Builder.hexadecimal + $ (truncate :: NominalDiffTime -> Int) + $ diffLocalTime localTime (LocalTime ttfEpoch midnight) + +dumpCVTable :: CVTable -> Text.Builder.Builder +dumpCVTable (CVTable cvTable) = dumpCaption "'cvt ' Table - Control Value Table" + <> "Size = " <> Text.Builder.decimal (tableSize * 2) + <> " bytes, " <> Text.Builder.decimal tableSize <> " entries\n" + <> foldMap (uncurry go) (zip [0..] cvTable) + where + tableSize = Prelude.length cvTable + go :: Int -> Int16 -> Text.Builder.Builder + go index' entry = justifyNumber 13 index' <> ". " + <> Text.Builder.decimal entry <> newlineBuilder + +dumpOs2 :: Os2Table -> Text.Builder.Builder +dumpOs2 = (dumpCaption "'OS/2' Table - OS/2 and Windows Metrics" <>) . go + where + go = \case + Os2Version0 baseFields msFields -> dumpBaseFields baseFields + <> maybe "" dumpMicrosoftFields msFields + Os2Version1 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion1Fields extraFields + Os2Version2 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields + Os2Version3 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields + Os2Version4 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields + Os2Version5 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion5Fields extraFields + dumpVersion1Fields Os2Version1Fields{..} + = " CodePage Range 1( Bits 0 - 31 ): " <> paddedHexadecimal ulCodePageRange1 <> newlineBuilder + <> " CodePage Range 2( Bits 32- 63 ): " <> paddedHexadecimal ulCodePageRange2 <> newlineBuilder + dumpVersion4Fields Os2Version4Fields{..} + = dumpVersion1Fields (Os2Version1Fields ulCodePageRange1 ulCodePageRange2) + <> " sxHeight: " <> Text.Builder.decimal sxHeight <> newlineBuilder + <> " sCapHeight: " <> Text.Builder.decimal sCapHeight <> newlineBuilder + <> " usDefaultChar: 0x" <> halfPaddedHexadecimal usDefaultChar <> newlineBuilder + <> " usBreakChar: 0x" <> halfPaddedHexadecimal usBreakChar <> newlineBuilder + <> " usMaxContext: " <> Text.Builder.decimal usMaxContext <> newlineBuilder + dumpVersion5Fields Os2Version5Fields{..} + = dumpVersion1Fields (Os2Version1Fields ulCodePageRange1 ulCodePageRange2) + <> " sxHeight: " <> Text.Builder.decimal sxHeight <> newlineBuilder + <> " sCapHeight: " <> Text.Builder.decimal sCapHeight <> newlineBuilder + <> " usDefaultChar: 0x" <> halfPaddedHexadecimal usDefaultChar <> newlineBuilder + <> " usBreakChar: 0x" <> halfPaddedHexadecimal usBreakChar <> newlineBuilder + <> " usMaxContext: " <> Text.Builder.decimal usMaxContext <> newlineBuilder + <> " usLowerOpticalPointSize: " + <> Text.Builder.decimal usLowerOpticalPointSize <> newlineBuilder + <> " usUpperOpticalPointSize: " + <> Text.Builder.decimal usUpperOpticalPointSize <> newlineBuilder + dumpMicrosoftFields Os2MicrosoftFields{..} + = " sTypoAscender: " <> Text.Builder.decimal sTypoAscender <> newlineBuilder + <> " sTypoDescender: " <> Text.Builder.decimal sTypoDescender <> newlineBuilder + <> " sTypoLineGap: " <> Text.Builder.decimal sTypoLineGap <> newlineBuilder + <> " usWinAscent: " <> Text.Builder.decimal usWinAscent <> newlineBuilder + <> " usWinDescent: " <> Text.Builder.decimal usWinDescent <> newlineBuilder + dumpBaseFields Os2BaseFields{..} + = " 'OS/2' version: " <> Text.Builder.decimal version <> newlineBuilder + <> " xAvgCharWidth: " <> Text.Builder.decimal xAvgCharWidth <> newlineBuilder + <> " usWeightClass: " <> weightClass usWeightClass <> newlineBuilder + <> " usWidthClass: " <> widthClass usWidthClass <> newlineBuilder + <> " fsType: " <> Text.Builder.decimal fsType <> newlineBuilder + <> " ySubscriptXSize: " <> Text.Builder.decimal ySubscriptXSize <> newlineBuilder + <> " ySubscriptYSize: " <> Text.Builder.decimal ySubscriptYSize <> newlineBuilder + <> " ySubscriptXOffset: " <> Text.Builder.decimal ySubscriptXOffset <> newlineBuilder + <> " ySubscriptYOffset: " <> Text.Builder.decimal ySubscriptYOffset <> newlineBuilder + <> " ySuperscriptXSize: " <> Text.Builder.decimal ySuperscriptXSize <> newlineBuilder + <> " ySuperscriptYSize: " <> Text.Builder.decimal ySuperscriptYSize <> newlineBuilder + <> " ySuperscriptXOffset: " <> Text.Builder.decimal ySuperscriptXOffset <> newlineBuilder + <> " ySuperscriptYOffset: " <> Text.Builder.decimal ySuperscriptYOffset <> newlineBuilder + <> " yStrikeoutSize: " <> Text.Builder.decimal yStrikeoutSize <> newlineBuilder + <> " yStrikeoutPosition: " <> Text.Builder.decimal yStrikeoutPosition <> newlineBuilder + <> " sFamilyClass:" <> familyClass sFamilyClass <> newlineBuilder + <> " PANOSE:" <> newlineBuilder <> dumpPanose panose + <> fold (Vector.imap dumpUnicodeRange ulUnicodeRange) + <> " achVendID: '" <> achVendID' achVendID <> "'\n" + <> " fsSelection: 0x" <> fsSelection' fsSelection <> newlineBuilder + <> " usFirstCharIndex: 0x" <> halfPaddedHexadecimal fsFirstCharIndex <> newlineBuilder + <> " usLastCharIndex: 0x" <> halfPaddedHexadecimal fsLastCharIndex <> newlineBuilder + fsSelection' value = + let description = fold + [ if testBit value 0 then "Italic " else "" + , if testBit value 5 then "Bold " else "" + ] + in halfPaddedHexadecimal value <> " '" <> description <> "'" + achVendID' = Text.Builder.fromText . Text.decodeLatin1 . ByteString.pack . fmap fromIntegral . toList + dumpUnicodeRange index value = + let bits = index * 32 + parens = "( Bits " <> Text.Builder.decimal bits <> " - " + <> Text.Builder.decimal (bits + 31) <> " ):" + in " Unicode Range: " <> Text.Builder.decimal (index + 1) + <> Text.Builder.fromLazyText (Text.Lazy.justifyLeft 25 ' ' (Text.Builder.toLazyText parens)) + <> paddedHexadecimal value + <> newlineBuilder + dumpPanose Panose{..} + = " Family Kind: " <> dumpPanoseField bFamilyType + <> " Serif Style: " <> dumpPanoseField bSerifStyle + <> " Weight: " <> dumpPanoseField bWeight + <> " Proportion: " <> dumpPanoseField bProportion + <> " Contrast: " <> dumpPanoseField bContrast + <> " Stroke: " <> dumpPanoseField bStrokeVariation + <> " Arm Style: " <> dumpPanoseField bArmStyle + <> " Lettreform: " <> dumpPanoseField bLetterform + <> " Midline: " <> dumpPanoseField bMidline + <> " X-height: " <> dumpPanoseField bXHeight + dumpPanoseField field' = + let numericField = Text.Builder.fromLazyText + $ Text.Lazy.justifyLeft 8 ' ' + $ Text.Builder.toLazyText + $ Text.Builder.decimal + $ fromEnum field' + in numericField + <> Text.Builder.singleton '\'' + <> Text.Builder.fromString (show field') + <> Text.Builder.singleton '\'' + <> newlineBuilder + familyClass value = + " " <> Text.Builder.decimal (value .>>. 8) <> " subclass = " <> Text.Builder.decimal (value .&. 0x00ff) + weightClass classValue + | Just wordValue <- fWeight classValue = Text.Builder.decimal classValue <> " '" <> wordValue <> "'" + | otherwise = Text.Builder.decimal classValue + widthClass classValue + | Just wordValue <- fWidth classValue = Text.Builder.decimal classValue <> " '" <> wordValue <> "'" + | otherwise = Text.Builder.decimal classValue + fWeight 100 = Just "Thin" + fWeight 200 = Just "Extra-light" + fWeight 300 = Just "Light" + fWeight 400 = Just "Normal" + fWeight 500 = Just "Medium" + fWeight 600 = Just "Semi-bold" + fWeight 700 = Just "Bold" + fWeight 800 = Just "Extra-bold" + fWeight 900 = Just "Black" + fWeight _ = Nothing + fWidth 1 = Just "Ultra-condensed" + fWidth 2 = Just "Extra-condensed" + fWidth 3 = Just "Condensed" + fWidth 4 = Just "Semi-condensed" + fWidth 5 = Just "Medium" + fWidth 6 = Just "Semi-expanded" + fWidth 7 = Just "Expanded" + fWidth 8 = Just "Extra-expanded" + fWidth 9 = Just "Ultra-expanded" + fWidth _ = Nothing + +dumpPost :: PostTable -> Text.Builder.Builder +dumpPost PostTable{ postHeader = PostHeader{..}, postSubtable } + = dumpCaption "'post' Table - PostScript" <> newlineBuilder + <> " 'post' format: " <> dumpFixed32 format <> newlineBuilder + <> " italicAngle: " <> dumpFixed32 format <> newlineBuilder + <> " underlinePosition: " <> Text.Builder.decimal underlinePosition <> newlineBuilder + <> " underlineThichness: " <> Text.Builder.decimal underlineThickness <> newlineBuilder + <> " isFixedPitch: " <> dNumber isFixedPitch <> newlineBuilder + <> " minMemType42: " <> dNumber minMemType42 <> newlineBuilder + <> " maxMemType42: " <> dNumber maxMemType42 <> newlineBuilder + <> " minMemType1: " <> dNumber minMemType1 <> newlineBuilder + <> " maxMemType1: " <> dNumber maxMemType1 <> newlineBuilder + <> dumpPostSubtable + where + dNumber = (<> Text.Builder.singleton 'd') . Text.Builder.decimal + dumpPostSubtable = case postSubtable of + None -> "" -- Format 1 and 3 do not require a subtable. + PostFormat2 PostFormat2Table{..} + -> " Format 2.0: Non-Standard (for PostScript) TrueType Glyph Set." <> newlineBuilder + <> " numGlyphs: " <> Text.Builder.decimal (Prelude.length glyphNameIndex) + <> newlineBuilder <> fold (Vector.imap (dumpFormat2Pair names) glyphNameIndex) + PostFormat25 _ -> "Format 2.5" + PostFormat4 _ -> "Format 4.0" + dumpFormat2Pair names index glyphNameIndex' + = " Glyf " <> justifyNumber 3 index + <> " -> " <> glyphType names glyphNameIndex' + <> newlineBuilder + glyphType names glyphNameIndex' + | glyphNameIndex' >= 0 + , glyphNameIndex' <= 257 = "Mac Glyph # " <> justifyNumber 3 glyphNameIndex' + | glyphNameIndex' >= 258 + , glyphNameIndex' <= 32767 = + let nameIndex = fromIntegral $ glyphNameIndex' - 258 + in "PSGlyph Name # " <> justifyNumber 3 (succ nameIndex) <> ", '" + <> Text.Builder.fromText (Text.decodeASCII (names Vector.! nameIndex)) + <> Text.Builder.singleton '\'' + | otherwise = "Reserved" + +dumpCmap :: CmapTable -> Text.Builder.Builder +dumpCmap CmapTable{..} + = dumpCaption "'cmap' Table - Character to Glyph Index Mapping Table" + <> " 'cmap' version: " <> Text.Builder.decimal version <> newlineBuilder + <> " number of encodings: " <> Text.Builder.decimal encodingsLength <> newlineBuilder + <> " number of subtables: " <> Text.Builder.decimal (Prelude.length subtables) <> newlineBuilder + <> newlineBuilder + <> snd (foldr dumpCmapEncoding (pred encodingsLength, "") encodings) <> newlineBuilder + <> snd (foldr dumpCmapSubTable (pred subTablesLength, "") subtables) <> newlineBuilder + where + encodingsLength = Prelude.length encodings + subTablesLength = IntMap.size subtables + dumpCmapEncoding CmapEncoding{..} (index, accumulator) = + let findSubTableIndex = Text.Builder.decimal + . Prelude.length + . filter ((< offset) . fromIntegral) + . IntMap.keys + summary = "Encoding " <> Text.Builder.decimal index + <> ". PlatformID: " <> Text.Builder.decimal platformID <> newlineBuilder + <> " EcodingID: " <> Text.Builder.decimal platformSpecificID <> newlineBuilder + <> " SubTable: " <> findSubTableIndex subtables + <> ", Offset: " <> paddedHexadecimal offset <> newlineBuilder + in (pred index, summary <> newlineBuilder <> accumulator) + dumpCmapSubTable currentSubTable (index, accumulator) = + let contents = "SubTable " <> Text.Builder.decimal index + <> ". " <> dumpCmapSubTableFormat currentSubTable + in (pred index, contents <> accumulator) + dumpCmapSubTableFormat = \case + (CmapFormat0 _) -> "Format 0" + (CmapFormat2 _) -> "Format 2" + (CmapFormat4 CmapFormat4Table{..}) -> + let segCount = Vector.length startCode + dumpSegment' = dumpSegment segCount glyphIndexArray + in "Format 4 - Segment mapping to delta values\n\ + \ Length: 994\n\ + \ Version: 0\n\ + \ segCount: " + <> Text.Builder.decimal segCount + <> newlineBuilder <> " searchRange: " + <> Text.Builder.decimal searchRange + <> newlineBuilder <> " entrySelector: " + <> Text.Builder.decimal entrySelector + <> newlineBuilder <> " rangeShift: " + <> Text.Builder.decimal (segCount * 2 - fromIntegral searchRange) + <> newlineBuilder + <> fold (Vector.izipWith4 (dumpSegmentSummary segCount) startCode endCode idDelta idRangeOffset) + <> " Number of glyphIndex " + <> Text.Builder.decimal (Vector.length glyphIndexArray) <> newlineBuilder + <> fold (Vector.imap dumpGlyphAtIndex glyphIndexArray) + <> fold (Vector.izipWith4 dumpSegment' startCode endCode idDelta idRangeOffset) + (CmapFormat6 _) -> "Format 6" + (CmapFormat8 _) -> "Format 8" + (CmapFormat10 _) -> "Format 10" + (CmapFormat12 _) -> "Format 12" + (CmapFormat13 _) -> "Format 13" + (CmapFormat14 _) -> "Format 14" + dumpSegment :: Int -> Vector Word16 -> Int -> Word16 -> Word16 -> Word16 -> Word16 -> Text.Builder.Builder + dumpSegment segCount glyphIndexArray' segmentIndex startCode' endCode' idDelta' idRangeOffset' = + let charRange = [startCode'..endCode'] + dumpSegmentCharIndex' = + dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode' + in "Segment " <> Text.Builder.decimal segmentIndex <> ":\n" + <> foldMap dumpSegmentCharIndex' charRange + dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode' charCode = + let calculateGlyphIndex' = + calculateGlyphIndex charCode segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode' + in " Char 0x" + <> halfPaddedHexadecimal charCode <> " -> Index " + <> Text.Builder.decimal calculateGlyphIndex' + <> newlineBuilder + dumpSegmentSummary segCount index startCode' endCode' idDelta' idRangeOffset' + = " Seg " <> justifyNumber 5 index + <> " : St = " <> halfPaddedHexadecimal startCode' + <> ", En = " <> halfPaddedHexadecimal endCode' + <> ", D = " <> justifyNumber 6 idDelta' + <> ", RO = " <> justifyNumber 6 idRangeOffset' + <> ", gId# = " <> dumpGlyphId index segCount idRangeOffset' + <> newlineBuilder + dumpGlyphId segmentIndex segCount idRangeOffset' + = maybe "N/A" Text.Builder.decimal + $ calculateGlyphId segmentIndex segCount idRangeOffset' + calculateGlyphIndex :: Word16 -> Int -> Int -> Vector Word16 -> Word16 -> Word16 -> Word16 -> Int + calculateGlyphIndex c segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode' = + let defaultIndex = fromIntegral $ c + idDelta' + addOffset = fromIntegral + . fromMaybe 0 + . (glyphIndexArray' Vector.!?) + . (+ fromIntegral (c - startCode')) + in maybe defaultIndex addOffset + $ calculateGlyphId segmentIndex segCount idRangeOffset' + calculateGlyphId segmentIndex segCount idRangeOffset' + | idRangeOffset' == 0 = Nothing + | otherwise = Just $ segmentIndex - segCount + (fromIntegral idRangeOffset' `div` 2) + dumpGlyphAtIndex index element = " glyphIdArray[" <> Text.Builder.decimal index <> "] = " + <> Text.Builder.decimal element <> newlineBuilder + +dumpLoca :: LocaTable -> Text.Builder.Builder +dumpLoca table = + dumpCaption "'loca' Table - Index to Location" + <> go table + where + go (LongLocaTable elements) = dumpElements elements + go (ShortLocaTable elements) = dumpElements + $ (* 2) + . (fromIntegral :: Word16 -> Word32) + <$> elements + dumpElements elements = + case Vector.unsnoc elements of + Just (init', last') + -> foldMap dumpLocaLine (Vector.indexed init') + <> " Ended at " <> paddedHexadecimal last' <> newlineBuilder + Nothing -> mempty + dumpLocaLine :: Integral a => (Int, a) -> Text.Builder.Builder + dumpLocaLine (index, element) + = " Idx " <> justifyNumber 6 index + <> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder + +dumpName :: NameTable -> Text.Builder.Builder +dumpName table'@NameTable{..} = dumpCaption "'name' Table - Naming Table" + <> " Format: " <> Text.Builder.decimal format <> newlineBuilder + <> " Number of Record: " <> Text.Builder.decimal (Prelude.length nameRecord) <> newlineBuilder + <> " Storage offset: " <> Text.Builder.decimal (nameStringOffset table') <> newlineBuilder + <> foldMap go (zip3 [0 :: Int ..] nameRecord variable) + where + go (index, NameRecord{ length = length', ..}, variable') + = "Name table " <> justifyNumber 3 index <> "." + <> " PlatformID: " <> Text.Builder.decimal platformID <> newlineBuilder + <> " EncodingID: " <> Text.Builder.decimal platformSpecificID <> newlineBuilder + <> " LanguageID: " <> Text.Builder.decimal languageID <> newlineBuilder + <> " NameID: " <> Text.Builder.decimal nameID <> newlineBuilder + <> " Length: " <> Text.Builder.decimal length' <> newlineBuilder + <> " Offset: " <> Text.Builder.decimal offset <> newlineBuilder + <> foldMap (" " <>) (dumpHexString $ ByteString.unpack variable') + +dumpHexString :: [Word8] -> [Text.Builder.Builder] +dumpHexString byteCodes + | null byteCodes = [dumpHexLine " > " byteCodes] + | Prelude.length byteCodes < 10 = [dumpHexLine " > " byteCodes] + | otherwise = dumpHexLine " > " byteCodes + : dumpHexString (drop 10 byteCodes) + where + dumpHexLine separator variable' = + let firstTen = take 10 variable' + digits = fold $ intersperse (Text.Builder.singleton ' ') $ hexByte <$> firstTen + printables = foldMap printableByte firstTen + in digits + <> Text.Builder.fromText (Text.replicate (10 - Prelude.length firstTen) " ") + <> separator + <> printables + <> newlineBuilder + printableByte :: Word8 -> Text.Builder.Builder + printableByte code + | code >= 0x20 + , code < 0x7f = Text.Builder.singleton $ toEnum $ fromIntegral code + | otherwise = Text.Builder.singleton '.' + +hexByte :: Integral a => a -> Text.Builder.Builder +hexByte = Text.Builder.fromLazyText + . Text.Lazy.justifyRight 2 '0' + . Text.Builder.toLazyText + . Text.Builder.hexadecimal + +dumpMaxp :: MaxpTable -> Text.Builder.Builder +dumpMaxp (TrueMaxp TrueMaxpTable{..}) + = dumpCaption "'maxp' Table - Maximum Profile" + <> " 'maxp' version: " <> dumpFixed32 version <> newlineBuilder + <> " numGlyphs: " <> Text.Builder.decimal numGlyphs <> newlineBuilder + <> " maxPoints: " <> Text.Builder.decimal maxPoints <> newlineBuilder + <> " maxContours: " <> Text.Builder.decimal maxContours <> newlineBuilder + <> " maxCompositePoints: " <> Text.Builder.decimal maxComponentPoints <> newlineBuilder + <> " maxCompositeContours: " <> Text.Builder.decimal maxComponentContours <> newlineBuilder + <> " maxZones: " <> Text.Builder.decimal maxZones <> newlineBuilder + <> " maxTwilightPoints: " <> Text.Builder.decimal maxTwilightPoints <> newlineBuilder + <> " maxStorage: " <> Text.Builder.decimal maxStorage <> newlineBuilder + <> " maxFunctionDefs: " <> Text.Builder.decimal maxFunctionDefs <> newlineBuilder + <> " maxInstructionDefs: " <> Text.Builder.decimal maxInstructionDefs <> newlineBuilder + <> " maxStackElements: " <> Text.Builder.decimal maxStackElements <> newlineBuilder + <> " maxSizeOfInstructions: " <> Text.Builder.decimal maxSizeOfInstructions <> newlineBuilder + <> " maxComponentElements: " <> Text.Builder.decimal maxComponentElements <> newlineBuilder + <> " maxCompoenetDepth: " <> Text.Builder.decimal maxComponentDepth <> newlineBuilder +dumpMaxp (OpenMaxp OpenMaxpTable{..}) + = dumpCaption "'maxp' Table - Maximum Profile" + <> " 'maxp' version: " <> dumpFixed32 version <> newlineBuilder <> newlineBuilder + <> " numGlyphs: " <> Text.Builder.decimal numGlyphs <> newlineBuilder + +dumpGASP :: GASPTable -> Text.Builder.Builder +dumpGASP GASPTable{..} = dumpCaption "'gasp' Table - Grid-fitting And Scan-conversion Procedure" + <> "'gasp' version: " <> Text.Builder.decimal version <> newlineBuilder + <> "numRanges: " <> Text.Builder.decimal (Prelude.length gaspRange) <> newlineBuilder + <> foldMap dumpGASPRange (zip [0..] gaspRange) + where + dumpGASPRange :: (Int, GASPRange) -> Text.Builder.Builder + dumpGASPRange (index', GASPRange{..}) = newlineBuilder + <> " gasp Range " <> Text.Builder.decimal index' <> newlineBuilder + <> " rangeMaxPPEM: " <> Text.Builder.decimal rangeMaxPPEM <> newlineBuilder + <> " rangeGaspBehavior: 0x" <> halfPaddedHexadecimal rangeGaspBehavior <> newlineBuilder + +dumpGlyf :: GlyfTable -> Text.Builder.Builder +dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data" + <> foldMap go (Vector.indexed glyfDescriptions) + where + go (glyphIndex, GlyphDescription{..}) + = "Glyph " <> justifyNumber 6 glyphIndex <> Text.Builder.singleton '.' <> newlineBuilder + <> " numberOfContours: " <> Text.Builder.decimal numberOfContours <> newlineBuilder + <> " xMin: " <> Text.Builder.decimal xMin <> newlineBuilder + <> " yMin: " <> Text.Builder.decimal yMin <> newlineBuilder + <> " xMax: " <> Text.Builder.decimal xMax <> newlineBuilder + <> " yMax: " <> Text.Builder.decimal yMax <> newlineBuilder + <> newlineBuilder <> dumpGlyphDefinition definition <> newlineBuilder + dumpEndPoint (endPointIndex, endPoint) + = " " <> justifyNumber 2 endPointIndex + <> ": " <> Text.Builder.decimal endPoint <> newlineBuilder + dumpGlyphDefinition (SimpleGlyph SimpleGlyphDefinition{..}) + = " EndPoints" <> newlineBuilder + <> " ---------" <> newlineBuilder + <> foldMap dumpEndPoint (Vector.indexed endPtsOfContours) <> newlineBuilder + <> " Length of Instructions: " + <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder + <> newlineBuilder <> " Flags" <> newlineBuilder + <> " -----" <> newlineBuilder + <> fst (Vector.foldl' foldFlag ("", 0) flags) <> newlineBuilder + <> " Coordinates" <> newlineBuilder + <> " -----------" <> newlineBuilder + <> fst (Vector.ifoldl' foldCoordinate mempty coordinates) + dumpGlyphDefinition (CompoundGlyph CompoundGlyphDefinition{..}) + = foldMap (dumpCompoundGlyph $ Vector.length components) (Vector.indexed components) + <> newlineBuilder <> " Length of Instructions: " + <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder + dumpCompoundGlyph :: Int -> (Int, ComponentGlyphPartDescription) -> Text.Builder.Builder + dumpCompoundGlyph componentsLength (componentIndex, description) = + let moreComponents = succ componentIndex < componentsLength + compoundFlags = dumpCompoundFlags moreComponents description + ComponentGlyphPartDescription{..} = description + in " " <> Text.Builder.decimal componentIndex + <> ": Flags: 0x" <> compoundFlags <> newlineBuilder + <> " Glyf Index: " <> Text.Builder.decimal glyphIndex <> newlineBuilder + <> " X" <> dumpArgument argument1 <> newlineBuilder + <> " Y" <> dumpArgument argument2 <> newlineBuilder + <> dumpTransformationOption transformationOption + <> " Others: " <> dumpOtherFlags flags <> newlineBuilder + <> newlineBuilder -- TODO + dumpTransformationOption GlyphNoScale = "" + dumpTransformationOption (GlyphScale scale) = + " X,Y Scale: " <> Text.Builder.realFloat (fixed2Double scale) <> newlineBuilder + dumpTransformationOption (GlyphXyScale xScale yScale) + = " X Scale: " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder + <> " Y Scale: " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder + dumpTransformationOption (Glyph2By2Scale xScale scale01 scale10 yScale) + = " X Scale: " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder + <> " X,Y Scale: " <> Text.Builder.realFloat (fixed2Double scale01) <> newlineBuilder + <> " Y,X Scale: " <> Text.Builder.realFloat (fixed2Double scale10) <> newlineBuilder + <> " Y Scale: " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder + dumpOtherFlags ComponentGlyphFlags{..} = + let roundXyToGridText = if roundXyToGrid then "Round X,Y to Grid " else " " + useMyMetricsText = if useMyMetrics then "Use My Metrics " else " " + overlapCompoundText = if overlapCompound then "Overlap " else " " + in roundXyToGridText <> overlapCompoundText <> useMyMetricsText + dumpCompoundFlags :: Bool -> ComponentGlyphPartDescription -> Text.Builder.Builder + dumpCompoundFlags moreComponents ComponentGlyphPartDescription{..} = + let setBits = glyphArgumentBits argument1 + <> componentFlagBits flags + <> transformationOptionBits transformationOption + setBits' = if moreComponents then 5 : setBits else setBits + in Text.Builder.hexadecimal + $ foldr (flip setBit) (zeroBits :: Word16) setBits' + dumpArgument (GlyphInt8Argument argument) = + " BOffset: " <> Text.Builder.decimal argument + dumpArgument (GlyphInt16Argument argument) = + " WOffset: " <> Text.Builder.decimal argument + dumpArgument (GlyphWord8Argument argument) = + " BPoint: " <> Text.Builder.decimal argument + dumpArgument (GlyphWord16Argument argument) = + " WPoint: " <> Text.Builder.decimal argument + glyphArgumentBits (GlyphInt16Argument _) = [0, 1] + glyphArgumentBits (GlyphWord16Argument _) = [0] + glyphArgumentBits (GlyphInt8Argument _) = [1] + glyphArgumentBits (GlyphWord8Argument _) = [] + componentFlagBits ComponentGlyphFlags{..} = catMaybes + [ if roundXyToGrid then Just 2 else Nothing + , if weHaveInstructions then Just 8 else Nothing + , if useMyMetrics then Just 9 else Nothing + , if overlapCompound then Just 10 else Nothing + ] + transformationOptionBits GlyphScale{} = [3] + transformationOptionBits GlyphXyScale{} = [6] + transformationOptionBits Glyph2By2Scale{} = [7] + transformationOptionBits GlyphNoScale = [] + dumpFlag lineValue coordinateIndex + = " " <> justifyNumber 2 coordinateIndex <> lineValue + foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int) + foldFlag (accumulator, coordinateIndex) OutlineFlag{..} = + let lineValue = ": " + <> (if thisYIsSame then "YDual " else " ") + <> (if thisXIsSame then "XDual " else " ") + <> (if repeat > 0 then "Repeat " else " ") + <> (if yShortVector then "Y-Short " else " ") + <> (if xShortVector then "X-Short " else " ") + <> (if onCurve then "On" else "Off") + <> newlineBuilder + repeatN = succIntegral repeat + repeatedLines = fold + $ Vector.cons accumulator + $ dumpFlag lineValue + <$> Vector.enumFromN coordinateIndex repeatN + in (repeatedLines, coordinateIndex + repeatN) + foldCoordinate + :: (Text.Builder.Builder, GlyphCoordinate) + -> Int + -> GlyphCoordinate + -> (Text.Builder.Builder, GlyphCoordinate) + foldCoordinate (accumulator, absCoordinate) coordinateIndex relCoordinate = + let nextAbs = relCoordinate <> absCoordinate + newLine = " " <> justifyNumber 2 coordinateIndex + <> " Rel " <> dumpCoordinate relCoordinate + <> " -> Abs " <> dumpCoordinate nextAbs + <> newlineBuilder + in (accumulator <> newLine, nextAbs) + dumpCoordinate GlyphCoordinate{..} + = "(" <> justifyNumber 7 coordinateX <> ", " + <> justifyNumber 7 coordinateY <> ")" + +dumpTables + :: Megaparsec.State ByteString Void + -> FontDirectory + -> Either DumpError Text.Builder.Builder +dumpTables processedState directory@FontDirectory{..} + = parseRequired >>= traverseDirectory + where + traverseDirectory parsedRequired = + let initial = Right $ dumpOffsetTable directory + in foldl' (go parsedRequired) initial tableDirectory + parseRequired = do + requiredHhea <- findRequired "hhea" hheaTableP + requiredHead@HeadTable{ indexToLocFormat } <- + findRequired "head" headTableP + requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat) + pure $ RequiredTables + { hheaTable = requiredHhea + , headTable = requiredHead + , locaTable = requiredLoca + } + findRequired tableName parser = + let missingError = Left $ DumpRequiredTableMissingError tableName + parseFound tableEntry = parseTable tableEntry parser processedState + in maybe missingError (first DumpParseError . parseFound) + $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory + go _ (Left accumulator) _ = Left accumulator + go parsedRequired (Right accumulator) tableEntry + = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) + $ dumpSubTable parsedRequired tableEntry + concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) + <$> builderDump + dumpSubTable RequiredTables{..} tableEntry = + case getField @"tag" tableEntry of + "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState + "head" -> Just $ Right $ dumpHead headTable + "hhea" -> Just $ Right $ dumpHhea hheaTable + "hmtx" -> Just $ dumpHmtx + <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState + "loca" -> Just $ Right $ dumpLoca locaTable + "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState + "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState + "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState + "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState + "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState + "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState + "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState + _ -> Nothing + +dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder +dumpTrueType ttfContents fontFile = + let initialState = Megaparsec.State + { stateInput = ttfContents + , stateOffset = 0 + , statePosState = Megaparsec.PosState + { pstateInput = ttfContents + , pstateOffset = 0 + , pstateSourcePos = Megaparsec.initialPos fontFile + , pstateTabWidth = Megaparsec.defaultTabWidth + , pstateLinePrefix = "" + } + , stateParseErrors = [] + } + (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState + + in first DumpParseError initialResult >>= dumpTables processedState |