855 lines
45 KiB
Haskell
855 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
|
|
, 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
|