Add font compression
This commit is contained in:
49
lib/Graphics/Fountainhead.hs
Normal file
49
lib/Graphics/Fountainhead.hs
Normal file
@ -0,0 +1,49 @@
|
||||
{- 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/. -}
|
||||
|
||||
-- | Convenience wrappers for working with font files.
|
||||
module Graphics.Fountainhead
|
||||
( dumpFontFile
|
||||
, parseFontDirectoryFromFile
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Void (Void)
|
||||
import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..))
|
||||
import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
|
||||
import Graphics.Fountainhead.TrueType (FontDirectory(..))
|
||||
import qualified Text.Megaparsec as Megaparsec
|
||||
import Text.Megaparsec (PosState(..), State(..))
|
||||
import System.IO (IOMode(..), withBinaryFile)
|
||||
import Data.Bifunctor (Bifunctor(..))
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import Graphics.Fountainhead.Compression (hDecompress)
|
||||
|
||||
parseFontDirectoryFromFile :: FilePath
|
||||
-> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
|
||||
parseFontDirectoryFromFile fontFile =
|
||||
withBinaryFile fontFile ReadMode withFontHandle
|
||||
where
|
||||
withFontHandle fontHandle = doParsing
|
||||
<$> hDecompress fontHandle
|
||||
doParsing ttfContents =
|
||||
let initialState = Megaparsec.State
|
||||
{ stateInput = ttfContents
|
||||
, stateOffset = 0
|
||||
, statePosState = Megaparsec.PosState
|
||||
{ pstateInput = ttfContents
|
||||
, pstateOffset = 0
|
||||
, pstateSourcePos = Megaparsec.initialPos fontFile
|
||||
, pstateTabWidth = Megaparsec.defaultTabWidth
|
||||
, pstateLinePrefix = ""
|
||||
}
|
||||
, stateParseErrors = []
|
||||
}
|
||||
in Megaparsec.runParser' fontDirectoryP initialState
|
||||
|
||||
dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
|
||||
dumpFontFile fontFile = do
|
||||
(processedState, initialResult) <- parseFontDirectoryFromFile fontFile
|
||||
|
||||
pure $ first DumpParseError initialResult >>= dumpTables processedState
|
||||
27
lib/Graphics/Fountainhead/Compression.hs
Normal file
27
lib/Graphics/Fountainhead/Compression.hs
Normal file
@ -0,0 +1,27 @@
|
||||
-- | Font compression and decompression.
|
||||
module Graphics.Fountainhead.Compression
|
||||
( compress
|
||||
, hDecompress
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as ByteString.Lazy
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Codec.Compression.Zlib as Zlib
|
||||
import System.IO (Handle, SeekMode(..), hFileSize, hSeek)
|
||||
|
||||
-- | Reads the font from a file handle decompressing it if needed.
|
||||
hDecompress :: Handle -> IO ByteString
|
||||
hDecompress fontHandle = do
|
||||
firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2
|
||||
hSeek fontHandle AbsoluteSeek 0
|
||||
fileSize <- fromIntegral <$> hFileSize fontHandle
|
||||
case firstBytes of
|
||||
0x78 : [secondByte]
|
||||
| secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] ->
|
||||
ByteString.Lazy.toStrict . Zlib.decompress
|
||||
<$> ByteString.Lazy.hGet fontHandle fileSize
|
||||
_ -> ByteString.hGetContents fontHandle
|
||||
|
||||
compress :: ByteString -> ByteString
|
||||
compress = ByteString.Lazy.toStrict . Zlib.compress . ByteString.Lazy.fromStrict
|
||||
854
lib/Graphics/Fountainhead/Dumper.hs
Normal file
854
lib/Graphics/Fountainhead/Dumper.hs
Normal file
@ -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
|
||||
1244
lib/Graphics/Fountainhead/Parser.hs
Normal file
1244
lib/Graphics/Fountainhead/Parser.hs
Normal file
File diff suppressed because it is too large
Load Diff
1318
lib/Graphics/Fountainhead/TrueType.hs
Normal file
1318
lib/Graphics/Fountainhead/TrueType.hs
Normal file
File diff suppressed because it is too large
Load Diff
41
lib/Graphics/Fountainhead/Type.hs
Normal file
41
lib/Graphics/Fountainhead/Type.hs
Normal file
@ -0,0 +1,41 @@
|
||||
{- 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/. -}
|
||||
|
||||
-- | Generic font types.
|
||||
module Graphics.Fountainhead.Type
|
||||
( F2Dot14(..)
|
||||
, Fixed32(..)
|
||||
, FWord
|
||||
, UFWord
|
||||
, fixed2Double
|
||||
, succIntegral
|
||||
, ttfEpoch
|
||||
) where
|
||||
|
||||
import Data.Bits ((.>>.), (.&.))
|
||||
import Data.Int (Int16)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Data.Time (Day(..))
|
||||
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
|
||||
|
||||
newtype Fixed32 = Fixed32 Word32
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype F2Dot14 = F2Dot14 Int16
|
||||
deriving (Eq, Show)
|
||||
|
||||
type FWord = Int16
|
||||
type UFWord = Word16
|
||||
|
||||
ttfEpoch :: Day
|
||||
ttfEpoch = fromOrdinalDate 1904 1
|
||||
|
||||
succIntegral :: Integral a => a -> Int
|
||||
succIntegral = succ . fromIntegral
|
||||
|
||||
fixed2Double :: F2Dot14 -> Double
|
||||
fixed2Double (F2Dot14 fixed) =
|
||||
let mantissa = realToFrac (fixed .>>. 14)
|
||||
fraction = realToFrac (fixed .&. 0x3fff) / 16384.0
|
||||
in mantissa + fraction
|
||||
Reference in New Issue
Block a user