summaryrefslogtreecommitdiff
path: root/src/Graphics
diff options
context:
space:
mode:
Diffstat (limited to 'src/Graphics')
-rw-r--r--src/Graphics/Fountainhead.hs50
-rw-r--r--src/Graphics/Fountainhead/Dumper.hs847
-rw-r--r--src/Graphics/Fountainhead/Parser.hs1244
-rw-r--r--src/Graphics/Fountainhead/TrueType.hs1318
-rw-r--r--src/Graphics/Fountainhead/Type.hs41
5 files changed, 0 insertions, 3500 deletions
diff --git a/src/Graphics/Fountainhead.hs b/src/Graphics/Fountainhead.hs
deleted file mode 100644
index f965680..0000000
--- a/src/Graphics/Fountainhead.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-{- 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/. -}
-
-module Graphics.Fountainhead
- ( parseFontDirectoryFromFile
- ) where
-
-import qualified Codec.Compression.Zlib as Zlib
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Lazy as ByteString.Lazy
-import Data.Void (Void)
-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(..), SeekMode(..), hFileSize, hSeek, withBinaryFile)
-
-parseFontDirectoryFromFile :: String
- -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
-parseFontDirectoryFromFile fontFile =
- withBinaryFile fontFile ReadMode withFontHandle
- where
- withFontHandle fontHandle = doParsing
- <$> readFontContents 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
- readFontContents 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
diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs
deleted file mode 100644
index adda06f..0000000
--- a/src/Graphics/Fountainhead/Dumper.hs
+++ /dev/null
@@ -1,847 +0,0 @@
-{- 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
-
-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
diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs
deleted file mode 100644
index 31dcd0e..0000000
--- a/src/Graphics/Fountainhead/Parser.hs
+++ /dev/null
@@ -1,1244 +0,0 @@
-{- 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 DuplicateRecordFields #-}
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeApplications #-}
-
--- | Font parser.
-module Graphics.Fountainhead.Parser
- ( Parser
- , ParseErrorBundle
- , cmapTableP
- , cvTableP
- , f2Dot14P
- , fixedP
- , fontDirectoryP
- , fpgmTableP
- , gaspTableP
- , glyfTableP
- , hdmxTableP
- , headTableP
- , hheaTableP
- , hmtxTableP
- , locaTableP
- , longDateTimeP
- , longLocaTableP
- , maxpTableP
- , nameTableP
- , os2TableP
- , panoseP
- , parseTable
- , pascalStringP
- , postTableP
- , prepTableP
- , shortLocaTableP
- , word24P
- ) where
-
-import Control.Applicative (Alternative(..))
-import Control.Monad (foldM, void)
-import Data.Bits (Bits(..))
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Builder as ByteString.Builder
-import qualified Data.ByteString.Lazy as ByteString.Lazy
-import Data.Foldable (Foldable(..))
-import Data.Int (Int8, Int16)
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.Functor (($>))
-import Data.List (sortOn, nubBy, sortBy)
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.Time
- ( LocalTime(..)
- , addDays
- , secondsToDiffTime
- , timeToTimeOfDay
- )
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import Data.Void (Void)
-import Data.Word (Word8, Word16, Word32)
-import GHC.Records (HasField(..))
-import Graphics.Fountainhead.TrueType
- ( BArmStyle(..)
- , BContrast(..)
- , BFamilyType(..)
- , BMidline(..)
- , BLetterform(..)
- , BProportion(..)
- , BSerifStyle(..)
- , BStrokeVariation(..)
- , BWeight(..)
- , BXHeight(..)
- , CVTable(..)
- , CmapSubtable(..)
- , CmapTable(..)
- , CmapEncoding(..)
- , CmapFormat0Table(..)
- , CmapFormat2Subheader(..)
- , CmapFormat2Table(..)
- , CmapFormat4Table(..)
- , CmapFormat6Table(..)
- , CmapGroup(..)
- , CmapFormat8Table(..)
- , CmapFormat10Table(..)
- , CmapFormat12Table(..)
- , CmapFormat13Table
- , CmapFormat14Table(..)
- , ComponentGlyphFlags(..)
- , ComponentGlyphPartDescription(..)
- , CompoundGlyphDefinition(..)
- , FpgmTable(..)
- , FontDirectionHint(..)
- , FontDirectory(..)
- , FontStyle(..)
- , GASPRange(..)
- , GASPTable(..)
- , GlyfTable(..)
- , GlyphArgument(..)
- , GlyphCoordinate(..)
- , GlyphDefinition(..)
- , GlyphDescription(..)
- , GlyphTransformationOption(..)
- , HdmxTable(..)
- , DeviceRecord(..)
- , HeadTable(..)
- , HheaTable(..)
- , HmtxTable(..)
- , IndexToLocFormat(..)
- , LocaTable(..)
- , LongHorMetric(..)
- , MaxpTable(..)
- , NameRecord(..)
- , NameTable(..)
- , OffsetSubtable(..)
- , OutlineFlag(..)
- , OpenMaxpTable(..)
- , Os2BaseFields(..)
- , Os2MicrosoftFields(..)
- , Os2Version1Fields(..)
- , Os2Version4Fields(..)
- , Os2Version5Fields(..)
- , Os2Table(..)
- , Panose(..)
- , PostFormat2Table(..)
- , PostHeader(..)
- , PostSubtable(..)
- , PostTable(..)
- , PrepTable(..)
- , SimpleGlyphDefinition(..)
- , TableDirectory(..)
- , TrueMaxpTable(..)
- , UVSOffset(..)
- , UVSMapping(..)
- , UnicodeValueRange(..)
- , VariationSelectorMap
- , unLocaTable
- )
-import Graphics.Fountainhead.Type
- ( F2Dot14(..)
- , Fixed32(..)
- , succIntegral
- , ttfEpoch
- )
-import Text.Megaparsec ((<?>))
-import qualified Text.Megaparsec as Megaparsec
-import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary
-
-type Parser = Megaparsec.Parsec Void ByteString
-type ParseErrorBundle = Megaparsec.ParseErrorBundle ByteString Void
-
--- * Font directory
-
-offsetSubtableP :: Parser OffsetSubtable
-offsetSubtableP = OffsetSubtable
- <$> Megaparsec.Binary.word32be
- <*> (fromIntegral <$> Megaparsec.Binary.word16be)
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
-
-tagP :: Parser ByteString
-tagP = ByteString.Lazy.toStrict
- . ByteString.Builder.toLazyByteString
- . ByteString.Builder.word32BE
- <$> Megaparsec.Binary.word32be
-
-tableDirectoryP :: Parser TableDirectory
-tableDirectoryP = TableDirectory
- <$> tagP
- <*> Megaparsec.Binary.word32be
- <*> (fromIntegral <$> Megaparsec.Binary.word32be)
- <*> (fromIntegral <$> Megaparsec.Binary.word32be)
-
-fontDirectoryP :: Parser FontDirectory
-fontDirectoryP = do
- offsetSubtable'@OffsetSubtable{ numTables } <- offsetSubtableP
- tableDirectories <- Megaparsec.count numTables tableDirectoryP
- pure $ FontDirectory
- { offsetSubtable = offsetSubtable'
- , tableDirectory = tableDirectories
- }
-
--- * Name table
-
-nameTableP :: Parser NameTable
-nameTableP = do
- format' <- Megaparsec.Binary.word16be
- count' <- fromIntegral <$> Megaparsec.Binary.word16be
- stringOffset' <- fromIntegral <$> Megaparsec.Binary.word16be
- nameRecord' <- Megaparsec.count count' nameRecordP
- -- 12 is the size of a single record, 6 is the header size.
- let padding = stringOffset' - count' * 12 - 6
- Megaparsec.skipCount padding Megaparsec.Binary.word8
- variable' <- Megaparsec.takeRest
- pure $ NameTable
- { format = format'
- , nameRecord = nameRecord'
- , variable = parseVariable variable' <$> nameRecord'
- }
- where
- parseVariable variable' NameRecord{ offset, length = length' } =
- ByteString.take length' $ ByteString.drop offset variable'
-
-nameRecordP :: Parser NameRecord
-nameRecordP = NameRecord
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> (fromIntegral <$> Megaparsec.Binary.word16be)
- <*> (fromIntegral <$> Megaparsec.Binary.word16be)
-
--- * 'cvt ' table
-
-cvTableP :: Parser CVTable
-cvTableP = CVTable
- <$> Megaparsec.many Megaparsec.Binary.int16be
- <* Megaparsec.eof
-
--- * Maximum profile table
-
-trueMaxpTableP :: Parser TrueMaxpTable
-trueMaxpTableP
- = Megaparsec.chunk (ByteString.pack [0, 1, 0, 0])
- *> subparser
- where
- subparser =
- TrueMaxpTable (Fixed32 0x00010000)
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
-
-openMaxpTableP :: Parser OpenMaxpTable
-openMaxpTableP
- = Megaparsec.chunk (ByteString.pack [0, 0, 0x50, 0])
- *> subparser
- where
- subparser =
- OpenMaxpTable (Fixed32 0x00005000)
- <$> Megaparsec.Binary.word16be
- <* Megaparsec.eof
-
-maxpTableP :: Parser MaxpTable
-maxpTableP
- = TrueMaxp <$> trueMaxpTableP
- <|> OpenMaxp <$> openMaxpTableP
-
--- * Horizontal header table
-
-hheaTableP :: Parser HheaTable
-hheaTableP = HheaTable
- <$> fixedP
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <* Megaparsec.Binary.int16be
- <* Megaparsec.Binary.int16be
- <* Megaparsec.Binary.int16be
- <* Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
- <* Megaparsec.eof
-
--- * Font header table
-
-headTableP :: Parser HeadTable
-headTableP = HeadTable
- <$> fixedP
- <*> fixedP
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> longDateTimeP
- <*> longDateTimeP
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> fontStyleP
- <*> Megaparsec.Binary.word16be
- <*> fontDirectionHintP
- <*> indexToLocFormatP
- <*> Megaparsec.Binary.word16be
- <* Megaparsec.eof
- where
- indexToLocFormatP = do
- indexToLocFormat' <- Megaparsec.Binary.int16be
- case indexToLocFormat' of
- 0 -> pure ShortOffsetIndexToLocFormat
- 1 -> pure LongOffsetIndexToLocFormat
- _ -> fail $ "Unknown loca table format indexToLocFormat: "
- <> show indexToLocFormat'
-
-fontStyleP :: Parser FontStyle
-fontStyleP = go <$> Megaparsec.Binary.word16be
- where
- go fontStyle' = FontStyle
- { bold = testBit fontStyle' 0
- , italic = testBit fontStyle' 1
- , underline = testBit fontStyle' 2
- , outline = testBit fontStyle' 3
- , shadow = testBit fontStyle' 4
- , condensed = testBit fontStyle' 5
- , extended = testBit fontStyle' 6
- }
-
-fontDirectionHintP :: Parser FontDirectionHint
-fontDirectionHintP
- = (Megaparsec.chunk (ByteString.pack [0, 0]) $> MixedDirectionalGlyphs)
- <|> (Megaparsec.chunk (ByteString.pack [0, 1]) $> StronglyLeftToRightGlyphs)
- <|> (Megaparsec.chunk (ByteString.pack [0, 2]) $> LeftToRightGlyphsWithNeutrals)
- <|> (Megaparsec.chunk (ByteString.pack [0xff, 0xff]) $> StronglyRightToLeftGlyphs)
- <|> (Megaparsec.chunk (ByteString.pack [0xff, 0xfe]) $> RightToLeftGlyphsWithNeutrals)
-
--- * Glyph data location table
-
-longLocaTableP :: Parser LocaTable
-longLocaTableP = LongLocaTable
- <$> vectorP Megaparsec.Binary.word32be
- <?> "loca table, long version"
-
-shortLocaTableP :: Parser LocaTable
-shortLocaTableP = ShortLocaTable
- <$> vectorP Megaparsec.Binary.word16be
- <?> "loca table, short version"
-
-locaTableP :: IndexToLocFormat -> Parser LocaTable
-locaTableP ShortOffsetIndexToLocFormat = shortLocaTableP
-locaTableP LongOffsetIndexToLocFormat = longLocaTableP
-
--- * Horizontal metrics table
-
-longHorMetricP :: Parser LongHorMetric
-longHorMetricP = LongHorMetric
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.int16be
-
-hmtxTableP :: Word16 -> Parser HmtxTable
-hmtxTableP numOfLongHorMetrics = HmtxTable
- <$> countP (fromIntegral numOfLongHorMetrics) longHorMetricP
- <*> Megaparsec.many Megaparsec.Binary.int16be
-
--- * Glyph name and PostScript font table
-
-postTableP :: Parser PostTable
-postTableP = do
- header'@PostHeader{ format } <- postHeaderP
- subtable' <- case format of
- Fixed32 0x00010000 -> pure None
- Fixed32 0x00020000 -> PostFormat2 <$> postFormat2TableP
- Fixed32 0x00025000 -> PostFormat25 <$> postFormat25TableP
- Fixed32 0x00030000 -> pure None
- Fixed32 0x00040000 -> PostFormat4 <$> postFormat4TableP
- _ -> fail $ "Unsupported post table format: " <> show format
- Megaparsec.eof
- pure $ PostTable
- { postHeader = header'
- , postSubtable = subtable'
- }
-
-postFormat2TableP :: Parser PostFormat2Table
-postFormat2TableP = do
- numberOfGlyphs <- fromIntegral <$> Megaparsec.Binary.word16be
- glyphNameIndex' <- Megaparsec.count numberOfGlyphs Megaparsec.Binary.word16be
- rest <- Megaparsec.many pascalStringP
- pure $ PostFormat2Table
- { glyphNameIndex = Vector.fromList glyphNameIndex'
- , names = Vector.fromList rest
- }
-
-postFormat25TableP :: Parser (Vector Int8)
-postFormat25TableP = Megaparsec.Binary.word16be
- >>= fmap Vector.fromList
- . flip Megaparsec.count Megaparsec.Binary.int8
- . fromIntegral
-
-postFormat4TableP :: Parser (Vector Word16)
-postFormat4TableP = Vector.fromList
- <$> Megaparsec.many Megaparsec.Binary.word16be
-
-postHeaderP :: Parser PostHeader
-postHeaderP = PostHeader
- <$> fixedP
- <*> fixedP
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
-
--- * Font program table
-
-fpgmTableP :: Parser FpgmTable
-fpgmTableP = FpgmTable
- <$> vectorP Megaparsec.Binary.word8
-
--- * Prep table
-
-prepTableP :: Parser PrepTable
-prepTableP = PrepTable
- <$> vectorP Megaparsec.Binary.word8
-
--- * Horizontal device metrics table
-
-deviceRecordP :: Int -> Parser DeviceRecord
-deviceRecordP size = do
- pixelSize' <- Megaparsec.Binary.word8
- maximumWidth' <- Megaparsec.Binary.word8
- widths' <- vectorNP size Megaparsec.Binary.word8
- let paddingLength = 4 - ((Vector.length widths' + 2) `mod` 4)
- Megaparsec.skipCount paddingLength
- $ Megaparsec.chunk
- $ ByteString.pack [0]
- pure $ DeviceRecord
- { pixelSize = pixelSize'
- , maximumWidth = maximumWidth'
- , widths = widths'
- }
-
-hdmxTableP :: Parser HdmxTable
-hdmxTableP = do
- void $ Megaparsec.chunk $ ByteString.pack [0, 0]
- numberOfDeviceRecords <- fromIntegral <$> Megaparsec.Binary.int16be
- sizeOfDeviceRecord <- fromIntegral <$> Megaparsec.Binary.int32be
- records' <- Megaparsec.count numberOfDeviceRecords
- $ deviceRecordP sizeOfDeviceRecord
- Megaparsec.eof
- pure $ HdmxTable 0 records'
-
--- * Glyph outline table
-
-glyphDescriptionP :: Parser GlyphDescription
-glyphDescriptionP = do
- numberOfContours' <- fromIntegral
- <$> Megaparsec.Binary.int16be
- <?> "numberOfContours"
- xMin' <- Megaparsec.Binary.int16be <?> "xMin"
- yMin' <- Megaparsec.Binary.int16be <?> "yMin"
- xMax' <- Megaparsec.Binary.int16be <?> "xMax"
- yMax' <- Megaparsec.Binary.int16be <?> "yMax"
- glyphDefinition <-
- if numberOfContours' >= 0
- then SimpleGlyph <$> simpleGlyphDefinitionP numberOfContours'
- else CompoundGlyph <$> compoundGlyphDefinitionP
- pure $ GlyphDescription
- { numberOfContours = numberOfContours'
- , xMin = xMin'
- , yMin = yMin'
- , xMax = xMax'
- , yMax = yMax'
- , definition = glyphDefinition
- }
-
-glyphInstructionsP :: Parser (Vector Word8)
-glyphInstructionsP = Megaparsec.Binary.word16be
- >>= flip vectorNP (Megaparsec.Binary.word8 <?> "compound glyph instruction")
- . fromIntegral
-
-compoundGlyphDefinitionP :: Parser CompoundGlyphDefinition
-compoundGlyphDefinitionP = do
- components' <- componentGlyphPartDescriptionP mempty
- let instructions' =
- if Vector.any (weHaveInstructions . getField @"flags") components'
- then glyphInstructionsP
- else pure mempty
- CompoundGlyphDefinition components' <$> instructions'
-
-componentGlyphPartDescriptionP
- ::Vector ComponentGlyphPartDescription
- -> Parser (Vector ComponentGlyphPartDescription)
-componentGlyphPartDescriptionP accumulator = do
- flags' <- Megaparsec.Binary.word16be <?> "flags"
- glyphIndex' <- Megaparsec.Binary.word16be <?> "glyphIndex"
- let arg1And2AreWords = testBit flags' 0
- argsAreXyValues = testBit flags' 1
- weHaveAScale = testBit flags' 3
- weHaveAnXAndYScale = testBit flags' 6
- weHaveATwoByTwo = testBit flags' 7
- argument1 <- glyphArgumentP arg1And2AreWords argsAreXyValues <?> "argument1"
- argument2 <- glyphArgumentP arg1And2AreWords argsAreXyValues <?> "argument2"
- transformationOption' <- transformationOptionP weHaveAScale weHaveAnXAndYScale weHaveATwoByTwo
- <?> "transformation option"
-
- let updated = Vector.snoc accumulator $ ComponentGlyphPartDescription
- { flags = ComponentGlyphFlags
- { roundXyToGrid = testBit flags' 2
- , weHaveInstructions = testBit flags' 8
- , useMyMetrics = testBit flags' 9
- , overlapCompound = testBit flags' 10
- }
- , glyphIndex = glyphIndex'
- , argument1 = argument1
- , argument2 = argument2
- , transformationOption = transformationOption'
- }
- -- MORE_COMPONENTS.
- if testBit flags' 5 then componentGlyphPartDescriptionP updated else pure updated
-
--- | Arguments are: WE_HAVE_A_SCALE, WE_HAVE_AN_X_AND_Y_SCALE and
--- WE_HAVE_A_TWO_BY_TWO.
-transformationOptionP :: Bool -> Bool -> Bool -> Parser GlyphTransformationOption
-transformationOptionP True _ _ = GlyphScale <$> f2Dot14P <?> "scale"
-transformationOptionP _ True _ = GlyphXyScale
- <$> f2Dot14P
- <*> f2Dot14P
- <?> "xy-scale"
-transformationOptionP _ _ True = Glyph2By2Scale
- <$> f2Dot14P
- <*> f2Dot14P
- <*> f2Dot14P
- <*> f2Dot14P
- <?> "2 by 2 transformation"
-transformationOptionP _ _ _ = pure GlyphNoScale
-
--- | Arguments are: ARG_1_AND_2_ARE_WORDS and ARGS_ARE_XY_VALUES.
-glyphArgumentP :: Bool -> Bool -> Parser GlyphArgument
-glyphArgumentP True True = GlyphInt16Argument
- <$> Megaparsec.Binary.int16be
- <?> "int16 argument"
-glyphArgumentP True False = GlyphWord16Argument
- <$> Megaparsec.Binary.word16be
- <?> "uint16 argument"
-glyphArgumentP False True = GlyphInt8Argument
- <$> Megaparsec.Binary.int8
- <?> "int8 argument"
-glyphArgumentP False False = GlyphWord8Argument
- <$> Megaparsec.Binary.word8
- <?> "uint8 argument"
-
-simpleGlyphDefinitionP :: Int -> Parser SimpleGlyphDefinition
-simpleGlyphDefinitionP numberOfContours' = do
- endPtsOfContours' <- vectorNP numberOfContours' Megaparsec.Binary.word16be
- <?> "endPtsOfContours"
- let numberOfPoints =
- if Vector.null endPtsOfContours'
- then 0
- else fromIntegral $ Vector.last endPtsOfContours'
- instructionLength <- fromIntegral
- <$> Megaparsec.Binary.word16be
- <?> "instructionLength"
- instructions' <- vectorNP instructionLength
- (Megaparsec.Binary.word8 <?> "simple glyph instruction")
- flags' <- flagsP numberOfPoints mempty <?> "flags"
- xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags'
- ys <- Vector.foldM (coordinatesP yFlagPair) mempty flags'
- pure $ SimpleGlyphDefinition
- { endPtsOfContours = endPtsOfContours'
- , instructions = instructions'
- , flags = flags'
- , coordinates = mkCoordinate <$> Vector.zip xs ys
- }
- where
- mkCoordinate (x, y) = GlyphCoordinate x y
- xFlagPair :: OutlineFlag -> (Bool, Bool)
- xFlagPair OutlineFlag{ xShortVector, thisXIsSame } =
- (xShortVector, thisXIsSame)
- yFlagPair :: OutlineFlag -> (Bool, Bool)
- yFlagPair OutlineFlag{ yShortVector, thisYIsSame } =
- (yShortVector, thisYIsSame)
- coordinateP :: Bool -> Bool -> Parser Int16
- coordinateP True True = fromIntegral
- <$> Megaparsec.Binary.word8
- <?> "1 byte long positive coordinate"
- coordinateP True False = negate . fromIntegral
- <$> Megaparsec.Binary.word8
- <?> "1 byte long negative coordinate"
- coordinateP False False = Megaparsec.Binary.int16be
- <?> "2 bytes long coordinate"
- coordinateP False True = pure 0
- coordinatesP
- :: (OutlineFlag -> (Bool, Bool))
- -> Vector Int16
- -> OutlineFlag
- -> Parser (Vector Int16)
- coordinatesP get accumulator first =
- let parser = uncurry coordinateP $ get first
- repeatN = succIntegral $ getField @"repeat" first
- in (accumulator <>) <$> vectorNP repeatN parser
- flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag)
- flagsP remaining accumulator
- | remaining < 0 = pure accumulator
- | otherwise = do
- flag <- Megaparsec.Binary.word8 <?> "outline flags"
- repeatN <-
- if testBit flag 3
- then fromIntegral
- <$> Megaparsec.Binary.word8
- <?> "flag repeat count"
- else pure 0
- let flag' = OutlineFlag
- { onCurve = testBit flag 0
- , xShortVector = testBit flag 1
- , yShortVector = testBit flag 2
- , repeat = fromIntegral repeatN
- , thisXIsSame = testBit flag 4
- , thisYIsSame = testBit flag 5
- }
- flagsP (remaining - repeatN - 1)
- $ Vector.snoc accumulator flag'
-
-glyfTableP :: LocaTable -> Parser GlyfTable
-glyfTableP locaTable
- | locaTable' <- unLocaTable locaTable
- , not $ Vector.null locaTable' =
- let locaInit = Vector.init locaTable'
- offsets = traverse go
- $ nubBy duplicate
- $ sortOn fst
- $ filter filterNullLength
- $ Vector.toList
- $ Vector.zip locaInit
- $ Vector.tail locaTable'
- in GlyfTable
- . Vector.generate (Vector.length locaInit)
- . generateTable locaInit
- . IntMap.fromList
- <$> offsets
- | otherwise = pure $ GlyfTable mempty
- where
- filterNullLength (x, y) = x /= y
- duplicate x y = fst x == fst y
- generateTable :: Vector Word32 -> IntMap GlyphDescription -> Int -> GlyphDescription
- generateTable locaInit offsetMap index =
- offsetMap IntMap.! fromIntegral (locaInit Vector.! index)
- go (locaOffset, nextOffset) = do
- startOffset <- Megaparsec.getOffset
- result <- glyphDescriptionP
- endOffset <- Megaparsec.getOffset
- flip Megaparsec.skipCount Megaparsec.Binary.word8
- $ fromIntegral nextOffset
- - fromIntegral locaOffset
- - endOffset
- + startOffset
- pure (fromIntegral locaOffset, result)
-
--- * Character to glyph mapping table
-
-cmapTableP :: Parser CmapTable
-cmapTableP = do
- initialOffset <- Megaparsec.getOffset
- version' <- Megaparsec.Binary.word16be
- numberSubtables <- fromIntegral <$> Megaparsec.Binary.word16be
- encodings' <- sortOn (getField @"offset")
- <$> Megaparsec.count numberSubtables cmapHeaderP
- parsedSubtables <- Megaparsec.some (subtableAtOffset initialOffset)
- Megaparsec.eof
- pure $ CmapTable
- { version = version'
- , encodings = encodings'
- , subtables = IntMap.fromList parsedSubtables
- }
- where
- subtableAtOffset initialOffset = do
- currentOffset <- flip (-) initialOffset <$> Megaparsec.getOffset
- parsedSubtable <- cmapFormatTableP
- pure (currentOffset, parsedSubtable)
-
-cmapHeaderP :: Parser CmapEncoding
-cmapHeaderP = CmapEncoding
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word32be
-
-cmapFormatTableP :: Parser CmapSubtable
-cmapFormatTableP = do
- format' <- Megaparsec.Binary.word16be
- case format' of
- 0 -> CmapFormat0 <$> cmapFormat0TableP
- 2 -> CmapFormat2 <$> cmapFormat2TableP
- 4 -> CmapFormat4 <$> cmapFormat4TableP
- 6 -> CmapFormat6 <$> cmapFormat6TableP
- 8 -> CmapFormat8 <$> cmapFormat8TableP
- 10 -> CmapFormat10 <$> cmapFormat10TableP
- 12 -> CmapFormat12 <$> cmapFormat12TableP
- 13 -> CmapFormat13 <$> cmapFormat13TableP
- 14 -> CmapFormat14 <$> cmapFormat14TableP
- _ -> fail $ "Unsupported format " <> show format' <> "."
-
-cmapFormat14TableP :: Parser CmapFormat14Table
-cmapFormat14TableP = do
- initialOffset <- (+ (-2)) <$> Megaparsec.getOffset
- void Megaparsec.Binary.word32be -- Length.
- numVarSelectorRecords <- fromIntegral <$> Megaparsec.Binary.word32be
- variationSelectorRecords' <- sortBy sortOffset . fold
- <$> Megaparsec.count numVarSelectorRecords variationSelectorRecordP
- let parseByOffset' = parseByOffset initialOffset
- CmapFormat14Table <$> foldM parseByOffset' IntMap.empty variationSelectorRecords'
- where
- parseByOffset
- :: Int
- -> VariationSelectorMap
- -> UVSOffset Word32 Word32
- -> Parser VariationSelectorMap
- parseByOffset _ accumulator uvsOffset'
- | uvsOffset uvsOffset' == 0 = pure accumulator
- parseByOffset tableOffset accumulator (DefaultUVSOffset varSelector' relativeOffset)
- -- If the records at this offset were already parsed, look at any parsed
- -- record and duplicate it updating the varSelector. The same logic
- -- applies for the next pattern match, but for non-default UVS.
- | Just member@(DefaultUVSOffset _ record :| _) <-
- IntMap.lookup (fromIntegral relativeOffset) accumulator =
-
- let newRecord = DefaultUVSOffset varSelector' record NonEmpty.<| member
- relativeOffset' = fromIntegral relativeOffset
- in pure $ IntMap.insert relativeOffset' newRecord accumulator
- | otherwise = do
- currentOffset <- Megaparsec.getOffset
- let emptyBytes = tableOffset + fromIntegral relativeOffset - currentOffset
- relativeOffset' = fromIntegral relativeOffset
- void $ Megaparsec.takeP Nothing emptyBytes
- entryCount <- fromIntegral <$> Megaparsec.Binary.word32be
- valueRanges <- vectorNP entryCount unicodeValueRangeP
- pure $ IntMap.insert relativeOffset' (DefaultUVSOffset varSelector' valueRanges :| []) accumulator
- parseByOffset tableOffset accumulator (NonDefaultUVSOffset varSelector' relativeOffset)
- | Just member@(NonDefaultUVSOffset _ record :| _) <-
- IntMap.lookup (fromIntegral relativeOffset) accumulator =
-
- let newRecord = NonDefaultUVSOffset varSelector' record NonEmpty.<| member
- relativeOffset' = fromIntegral relativeOffset
- in pure $ IntMap.insert relativeOffset' newRecord accumulator
- | otherwise = do
- currentOffset <- Megaparsec.getOffset
- let emptyBytes = tableOffset + fromIntegral relativeOffset - currentOffset
- void $ Megaparsec.takeP Nothing emptyBytes
- entryCount <- fromIntegral <$> Megaparsec.Binary.word32be
- flip (IntMap.insert $ fromIntegral relativeOffset) accumulator
- . pure
- . NonDefaultUVSOffset varSelector'
- <$> vectorNP entryCount uvsMappingP
- sortOffset x y = compare (uvsOffset x) (uvsOffset y)
-
-uvsOffset :: forall a. UVSOffset a a -> a
-uvsOffset (DefaultUVSOffset _ x) = x
-uvsOffset (NonDefaultUVSOffset _ x) = x
-
-variationSelectorRecordP :: Parser [UVSOffset Word32 Word32]
-variationSelectorRecordP = do
- varSelector' <- word24P
- defaultUVSOffset' <- Megaparsec.Binary.word32be
- nonDefaultUVSOffset' <- Megaparsec.Binary.word32be
-
- pure
- [ DefaultUVSOffset varSelector' defaultUVSOffset'
- , NonDefaultUVSOffset varSelector' nonDefaultUVSOffset'
- ]
-
-uvsMappingP :: Parser UVSMapping
-uvsMappingP = UVSMapping
- <$> word24P
- <*> Megaparsec.Binary.word16be
-
-unicodeValueRangeP :: Parser UnicodeValueRange
-unicodeValueRangeP = UnicodeValueRange
- <$> word24P
- <*> Megaparsec.Binary.word8
-
-cmapFormat13TableP :: Parser CmapFormat13Table
-cmapFormat13TableP = cmapFormat12TableP
-
-cmapFormat12TableP :: Parser CmapFormat12Table
-cmapFormat12TableP = do
- void $ Megaparsec.takeP Nothing 6 -- Reserved and length.
- language' <- Megaparsec.Binary.word32be
- nGroups <- fromIntegral <$> Megaparsec.Binary.word32be
- groups' <- vectorNP nGroups cmapGroupP
-
- pure $ CmapFormat12Table
- { language = language'
- , groups = groups'
- }
-
-cmapFormat10TableP :: Parser CmapFormat10Table
-cmapFormat10TableP = do
- void $ Megaparsec.takeP Nothing 2 -- Reserved.
- length' <- fromIntegral <$> Megaparsec.Binary.word32be
- language' <- Megaparsec.Binary.word32be
- startCharCode' <- Megaparsec.Binary.word32be
- numChars' <- Megaparsec.Binary.word32be
- let remainingLength = div (length' - 24) 2
- glyphs' <- vectorNP remainingLength Megaparsec.Binary.word16be
-
- pure $ CmapFormat10Table
- { language = language'
- , startCharCode = startCharCode'
- , numChars = numChars'
- , glyphs = glyphs'
- }
-
-cmapFormat8TableP :: Parser CmapFormat8Table
-cmapFormat8TableP = do
- void $ Megaparsec.takeP Nothing 6 -- Reserved and length.
- language' <- Megaparsec.Binary.word32be
- is32' <- Megaparsec.takeP Nothing 65536
- nGroups <- fromIntegral <$> Megaparsec.Binary.word32be
- groups' <- vectorNP nGroups cmapGroupP
-
- pure $ CmapFormat8Table
- { language = language'
- , is32 = ByteString.unpack is32'
- , groups = groups'
- }
-
-cmapGroupP :: Parser CmapGroup
-cmapGroupP = CmapGroup
- <$> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
-
-cmapFormat6TableP :: Parser CmapFormat6Table
-cmapFormat6TableP = do
- void Megaparsec.Binary.word16be -- Length.
- language' <- Megaparsec.Binary.word16be
- firstCode' <- Megaparsec.Binary.word16be
- entryCount' <- fromIntegral <$> Megaparsec.Binary.word16be
- glyphIndexArray' <- vectorNP entryCount' Megaparsec.Binary.word16be
-
- pure $ CmapFormat6Table
- { language = language'
- , firstCode = firstCode'
- , glyphIndexArray = glyphIndexArray'
- }
-
-cmapFormat4TableP :: Parser CmapFormat4Table
-cmapFormat4TableP = do
- length' <- fromIntegral <$> Megaparsec.Binary.word16be
- language' <- Megaparsec.Binary.word16be
- segCount <- fromIntegral . (`div` 2) <$> Megaparsec.Binary.word16be
- searchRange' <- Megaparsec.Binary.word16be
- entrySelector' <- Megaparsec.Binary.word16be
- rangeShift' <- Megaparsec.Binary.word16be
- endCode' <- vectorNP segCount Megaparsec.Binary.word16be
- void $ Megaparsec.chunk $ ByteString.pack [0, 0] -- reservedPad 0.
- startCode' <- vectorNP segCount Megaparsec.Binary.word16be
- idDelta' <- vectorNP segCount Megaparsec.Binary.word16be
- idRangeOffset' <- vectorNP segCount Megaparsec.Binary.word16be
- let glyphIndexLength = div (length' - 16 - segCount * 8) 2
- glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be
-
- pure $ CmapFormat4Table
- { language = language'
- , searchRange = searchRange'
- , entrySelector = entrySelector'
- , rangeShift = rangeShift'
- , endCode = endCode'
- , startCode = startCode'
- , idDelta = idDelta'
- , idRangeOffset = idRangeOffset'
- , glyphIndexArray = glyphIndexArray'
- }
-
-cmapFormat2TableP :: Parser CmapFormat2Table
-cmapFormat2TableP = do
- length' <- fromIntegral <$> Megaparsec.Binary.word16be
- language' <- Megaparsec.Binary.word16be
- subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be
- let maxIndex = succIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys'
- subHeaders' <- vectorNP maxIndex cmapFormat2SubheaderP
- let glyphIndexLength = div (length' - 518 - maxIndex * 8) 2
- glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be
-
- pure $ CmapFormat2Table
- { language = language'
- , subHeaderKeys = subHeaderKeys'
- , subHeaders = subHeaders'
- , glyphIndexArray = glyphIndexArray'
- }
-
-cmapFormat2SubheaderP :: Parser CmapFormat2Subheader
-cmapFormat2SubheaderP = CmapFormat2Subheader
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
-
-cmapFormat0TableP :: Parser CmapFormat0Table
-cmapFormat0TableP = CmapFormat0Table
- <$> Megaparsec.Binary.word16be
- <* Megaparsec.Binary.word16be
- <*> vectorNP 256 Megaparsec.Binary.word8
-
--- * Generic parsing utilities
-
-word24P :: Parser Word32
-word24P = foldr unstep 0 . ByteString.unpack
- <$> Megaparsec.takeP (Just "word24") 3
- where
- unstep b a = a `shiftL` 8 .|. fromIntegral b
-
-f2Dot14P :: Parser F2Dot14
-f2Dot14P = F2Dot14 <$> Megaparsec.Binary.int16be
-
-vectorP :: forall a. Parser a -> Parser (Vector a)
-vectorP = fmap Vector.fromList . Megaparsec.many
-
-vectorNP :: forall a. Int -> Parser a -> Parser (Vector a)
-vectorNP size = fmap Vector.fromList . Megaparsec.count size
-
-pascalStringP :: Parser ByteString
-pascalStringP = Megaparsec.Binary.word8
- >>= fmap ByteString.pack
- . flip Megaparsec.count Megaparsec.Binary.word8
- . fromIntegral
-
-countP :: forall a. Int -> Parser a -> Parser (NonEmpty a)
-countP number parser
- = (:|)
- <$> parser
- <*> Megaparsec.count (number - 1) parser
-
-longDateTimeP :: Parser LocalTime
-longDateTimeP = go <$> Megaparsec.Binary.int64be
- where
- go totalSeconds =
- let (totalDays, secondsOfDay) = totalSeconds `divMod` (3600 * 24)
- in LocalTime
- { localDay = addDays (fromIntegral totalDays) ttfEpoch
- , localTimeOfDay = timeToTimeOfDay
- $ secondsToDiffTime
- $ fromIntegral secondsOfDay
- }
-
-fixedP :: Parser Fixed32
-fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be
-
-parseTable
- :: TableDirectory
- -> Parser a
- -> Megaparsec.State ByteString Void
- -> Either ParseErrorBundle a
-parseTable TableDirectory{ offset, length = length' } parser state = snd
- $ Megaparsec.runParser' parser
- $ state
- { Megaparsec.stateInput = stateInput
- , Megaparsec.stateOffset = stateOffset
- , Megaparsec.statePosState = posState
- { Megaparsec.pstateInput = stateInput
- , Megaparsec.pstateOffset = stateOffset
- }
- }
- where
- posState = Megaparsec.statePosState state
- stateInput = ByteString.take length'
- $ ByteString.drop (offset - Megaparsec.stateOffset state)
- $ Megaparsec.stateInput state
- stateOffset = offset
-
--- * OS/2 table
-
-os2TableP :: Parser Os2Table
-os2TableP = do
- baseFields <- os2BaseFieldsP
- result <- case getField @"version" baseFields of
- 0 -> Os2Version0 baseFields
- <$> Megaparsec.optional os2MicrosoftFieldsP
- 1 -> Os2Version1 baseFields
- <$> os2MicrosoftFieldsP
- <*> os2Version1FieldsP
- 2 -> Os2Version2 baseFields
- <$> os2MicrosoftFieldsP
- <*> os2Version4FieldsP
- 3 -> Os2Version3 baseFields
- <$> os2MicrosoftFieldsP
- <*> os2Version4FieldsP
- 4 -> Os2Version4 baseFields
- <$> os2MicrosoftFieldsP
- <*> os2Version4FieldsP
- 5 -> Os2Version5 baseFields
- <$> os2MicrosoftFieldsP
- <*> os2Version5FieldsP
- unsupportedVersion -> fail
- $ "Unsupported OS/2 version: " <> show unsupportedVersion
- Megaparsec.eof
- pure result
-
-os2BaseFieldsP :: Parser Os2BaseFields
-os2BaseFieldsP = Os2BaseFields
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> panoseP
- <*> vectorNP 4 Megaparsec.Binary.word32be
- <*> vectorNP 4 Megaparsec.Binary.int8
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
-
-os2MicrosoftFieldsP :: Parser Os2MicrosoftFields
-os2MicrosoftFieldsP = Os2MicrosoftFields
- <$> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
-
-os2Version1FieldsP :: Parser Os2Version1Fields
-os2Version1FieldsP = Os2Version1Fields
- <$> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
-
-os2Version4FieldsP :: Parser Os2Version4Fields
-os2Version4FieldsP = Os2Version4Fields
- <$> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
-
-os2Version5FieldsP :: Parser Os2Version5Fields
-os2Version5FieldsP = Os2Version5Fields
- <$> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.word32be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.int16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
-
-panoseP :: Parser Panose
-panoseP = Panose
- <$> bFamilyTypeP
- <*> bSerifStyleP
- <*> bWeightP
- <*> bProportionP
- <*> bContrastP
- <*> bStrokeVariationP
- <*> bArmStyleP
- <*> bLetterformP
- <*> bMidlineP
- <*> bXHeightP
-
-bFamilyTypeP :: Parser BFamilyType
-bFamilyTypeP
- = (Megaparsec.single 0 $> AnyFamilyType)
- <|> (Megaparsec.single 1 $> NoFitFamilyType)
- <|> (Megaparsec.single 2 $> TextAndDisplayFamilyType)
- <|> (Megaparsec.single 3 $> ScriptFamilyType)
- <|> (Megaparsec.single 4 $> DecorativeFamilyType)
- <|> (Megaparsec.single 5 $> PictorialFamilyType)
- <?> "bFamilyType"
-
-bSerifStyleP :: Parser BSerifStyle
-bSerifStyleP
- = (Megaparsec.single 0 $> AnySerifStyle)
- <|> (Megaparsec.single 1 $> NoFitSerifStyle)
- <|> (Megaparsec.single 2 $> CoveSerifStyle)
- <|> (Megaparsec.single 3 $> ObtuseCoveSerifStyle)
- <|> (Megaparsec.single 4 $> SquareCoveSerifStyle)
- <|> (Megaparsec.single 5 $> ObtuseSquareCoveSerifStyle)
- <|> (Megaparsec.single 6 $> SquareSerifStyle)
- <|> (Megaparsec.single 7 $> ThinSerifStyle)
- <|> (Megaparsec.single 8 $> BoneSerifStyle)
- <|> (Megaparsec.single 9 $> ExaggeratedSerifStyle)
- <|> (Megaparsec.single 10 $> TriangleSerifStyle)
- <|> (Megaparsec.single 11 $> NormalSansSerifStyle)
- <|> (Megaparsec.single 12 $> ObtuseSansSerifStyle)
- <|> (Megaparsec.single 13 $> PerpSansSerifStyle)
- <|> (Megaparsec.single 14 $> FlaredSerifStyle)
- <|> (Megaparsec.single 15 $> RoundedSerifStyle)
- <?> "bSerifStyle"
-
-bWeightP :: Parser BWeight
-bWeightP
- = (Megaparsec.single 0 $> AnyWeight)
- <|> (Megaparsec.single 1 $> NoFitWeight)
- <|> (Megaparsec.single 2 $> VeryLightWeight)
- <|> (Megaparsec.single 3 $> LightWeight)
- <|> (Megaparsec.single 4 $> ThinWeight)
- <|> (Megaparsec.single 5 $> BookWeight)
- <|> (Megaparsec.single 6 $> MediumWeight)
- <|> (Megaparsec.single 7 $> DemiWeight)
- <|> (Megaparsec.single 8 $> BoldWeight)
- <|> (Megaparsec.single 9 $> HeavyWeight)
- <|> (Megaparsec.single 10 $> BlackWeight)
- <|> (Megaparsec.single 11 $> NordWeight)
- <?> "bWeight"
-
-bProportionP :: Parser BProportion
-bProportionP
- = (Megaparsec.single 0 $> AnyProportion)
- <|> (Megaparsec.single 1 $> NoFitProportion)
- <|> (Megaparsec.single 2 $> OldStyleProportion)
- <|> (Megaparsec.single 3 $> ModernProportion)
- <|> (Megaparsec.single 4 $> EvenWidthProportion)
- <|> (Megaparsec.single 5 $> ExpandedProportion)
- <|> (Megaparsec.single 6 $> CondensedProportion)
- <|> (Megaparsec.single 7 $> VeryExpandedProportion)
- <|> (Megaparsec.single 8 $> VeryCondensedProportion)
- <|> (Megaparsec.single 9 $> MonospacedProportion)
- <?> "bProportion"
-
-bContrastP :: Parser BContrast
-bContrastP
- = (Megaparsec.single 0 $> AnyContrast)
- <|> (Megaparsec.single 1 $> NoFitContrast)
- <|> (Megaparsec.single 2 $> NoneContrast)
- <|> (Megaparsec.single 3 $> VeryLowContrast)
- <|> (Megaparsec.single 4 $> LowContrast)
- <|> (Megaparsec.single 5 $> MediumLowContrast)
- <|> (Megaparsec.single 6 $> MediumContrast)
- <|> (Megaparsec.single 7 $> MediumHighContrast)
- <|> (Megaparsec.single 8 $> HighContrast)
- <|> (Megaparsec.single 9 $> VeryHighContrast)
- <?> "bContrast"
-
-bStrokeVariationP :: Parser BStrokeVariation
-bStrokeVariationP
- = (Megaparsec.single 0 $> AnyStrokeVariation)
- <|> (Megaparsec.single 1 $> NoFitStrokeVariation)
- <|> (Megaparsec.single 2 $> GradualDiagonalStrokeVariation)
- <|> (Megaparsec.single 3 $> GradualTransitionalStrokeVariation)
- <|> (Megaparsec.single 4 $> GradualVerticalStrokeVariation)
- <|> (Megaparsec.single 5 $> GradualHorizontalStrokeVariation)
- <|> (Megaparsec.single 6 $> RapidVerticalStrokeVariation)
- <|> (Megaparsec.single 7 $> RapidHorizontalStrokeVariation)
- <|> (Megaparsec.single 8 $> InstantVerticalStrokeVariation)
- <?> "bStrokeVariation"
-
-bArmStyleP :: Parser BArmStyle
-bArmStyleP
- = (Megaparsec.single 0 $> AnyArmStyle)
- <|> (Megaparsec.single 1 $> NoFitArmStyle)
- <|> (Megaparsec.single 2 $> StraightArmsHorizontalArmStyle)
- <|> (Megaparsec.single 3 $> StraightArmsWedgeArmStyle)
- <|> (Megaparsec.single 4 $> StraightArmsVerticalArmStyle)
- <|> (Megaparsec.single 5 $> StraightArmsSingleSerifArmStyle)
- <|> (Megaparsec.single 6 $> StraightArmsDoubleSerifArmStyle)
- <|> (Megaparsec.single 7 $> NonStraightArmsHorizontalArmStyle)
- <|> (Megaparsec.single 8 $> NonStraightArmsWedgeArmStyle)
- <|> (Megaparsec.single 9 $> NonStraightArmsVerticalArmStyle)
- <|> (Megaparsec.single 10 $> NonStraightArmsSingleSerifArmStyle)
- <|> (Megaparsec.single 11 $> NonStraightArmsDoubleSerifArmStyle)
- <?> "bArmStyle"
-
-bLetterformP :: Parser BLetterform
-bLetterformP
- = (Megaparsec.single 0 $> AnyLetterform)
- <|> (Megaparsec.single 1 $> NoFitLetterform)
- <|> (Megaparsec.single 2 $> NormalContactLetterform)
- <|> (Megaparsec.single 3 $> NormalWeightedLetterform)
- <|> (Megaparsec.single 4 $> NormalBoxedLetterform)
- <|> (Megaparsec.single 5 $> NormalFlattenedLetterform)
- <|> (Megaparsec.single 6 $> NormalRoundedLetterform)
- <|> (Megaparsec.single 7 $> NormalOffCenterLetterform)
- <|> (Megaparsec.single 8 $> NormalSquareLetterform)
- <|> (Megaparsec.single 9 $> ObliqueContactLetterform)
- <|> (Megaparsec.single 10 $> ObliqueWeightedLetterform)
- <|> (Megaparsec.single 11 $> ObliqueBoxedLetterform)
- <|> (Megaparsec.single 12 $> ObliqueFlattenedLetterform)
- <|> (Megaparsec.single 13 $> ObliqueRoundedLetterform)
- <|> (Megaparsec.single 14 $> ObliqueOffCenterLetterform)
- <|> (Megaparsec.single 15 $> ObliqueSquareLetterform)
- <?> "bLetterform"
-
-bXHeightP :: Parser BXHeight
-bXHeightP
- = (Megaparsec.single 0 $> AnyXHeight)
- <|> (Megaparsec.single 1 $> NoFitXHeight)
- <|> (Megaparsec.single 2 $> ConstantSmallXHeight)
- <|> (Megaparsec.single 3 $> ConstantStandardXHeight)
- <|> (Megaparsec.single 4 $> ConstantLargeXHeight)
- <|> (Megaparsec.single 5 $> DuckingSmallXHeight)
- <|> (Megaparsec.single 6 $> DuckingStandardXHeight)
- <|> (Megaparsec.single 7 $> DuckingLargeXHeight)
- <?> "bXHeight"
-
-bMidlineP :: Parser BMidline
-bMidlineP
- = (Megaparsec.single 0 $> AnyMidline)
- <|> (Megaparsec.single 1 $> NoFitMidline)
- <|> (Megaparsec.single 2 $> StandardTrimmedMidline)
- <|> (Megaparsec.single 3 $> StandardPointedMidline)
- <|> (Megaparsec.single 4 $> StandardSerifedMidline)
- <|> (Megaparsec.single 5 $> HighTrimmedMidline)
- <|> (Megaparsec.single 6 $> HighPointedMidline)
- <|> (Megaparsec.single 7 $> HighSerifedMidline)
- <|> (Megaparsec.single 8 $> ConstantTrimmedMidline)
- <|> (Megaparsec.single 9 $> ConstantPointedMidline)
- <|> (Megaparsec.single 10 $> ConstantSerifedMidline)
- <|> (Megaparsec.single 11 $> LowTrimmedMidline)
- <|> (Megaparsec.single 12 $> LowPointedMidline)
- <|> (Megaparsec.single 13 $> LowSerifedMidline)
- <?> "bMidline"
-
--- * Grid-fitting And Scan-conversion Procedure.
-
-gaspTableP :: Parser GASPTable
-gaspTableP = do
- version' <- Megaparsec.Binary.word16be
- numberRanges <- fromIntegral <$> Megaparsec.Binary.word16be
- parsedRanges <- Megaparsec.count numberRanges gaspRangeP
- Megaparsec.eof
- pure $ GASPTable
- { version = version'
- , gaspRange = parsedRanges
- }
- where
- gaspRangeP = GASPRange
- <$> Megaparsec.Binary.word16be
- <*> Megaparsec.Binary.word16be
diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs
deleted file mode 100644
index 0c15081..0000000
--- a/src/Graphics/Fountainhead/TrueType.hs
+++ /dev/null
@@ -1,1318 +0,0 @@
-{- 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 DuplicateRecordFields #-}
-{-# LANGUAGE RecordWildCards #-}
-
--- | Types representing a TrueType font.
-module Graphics.Fountainhead.TrueType
- ( BArmStyle(..)
- , BContrast(..)
- , BFamilyType(..)
- , BLetterform(..)
- , BMidline(..)
- , BProportion(..)
- , BSerifStyle(..)
- , BStrokeVariation(..)
- , BWeight(..)
- , BXHeight(..)
- , CVTable(..)
- , CmapSubtable(..)
- , CmapTable(..)
- , CmapEncoding(..)
- , CmapFormat0Table(..)
- , CmapFormat2Subheader(..)
- , CmapFormat2Table(..)
- , CmapFormat4Table(..)
- , CmapFormat6Table(..)
- , CmapGroup(..)
- , CmapFormat8Table(..)
- , CmapFormat10Table(..)
- , CmapFormat12Table(..)
- , CmapFormat13Table
- , CmapFormat14Table(..)
- , ComponentGlyphFlags(..)
- , ComponentGlyphPartDescription(..)
- , CompoundGlyphDefinition(..)
- , DeviceRecord(..)
- , FpgmTable(..)
- , FontDirectionHint(..)
- , FontDirectory(..)
- , FontStyle(..)
- , GASPRange(..)
- , GASPTable(..)
- , GlyfTable(..)
- , GlyphArgument(..)
- , GlyphCoordinate(..)
- , GlyphDefinition(..)
- , GlyphDescription(..)
- , GlyphTransformationOption(..)
- , HdmxTable(..)
- , HeadTable(..)
- , HheaTable(..)
- , HmtxTable(..)
- , IndexToLocFormat(..)
- , LocaTable(..)
- , LongHorMetric(..)
- , MaxpTable(..)
- , NameRecord(..)
- , NameTable(..)
- , OffsetSubtable(..)
- , OpenMaxpTable(..)
- , Os2BaseFields(..)
- , Os2MicrosoftFields(..)
- , Os2Table(..)
- , Os2Version1Fields(..)
- , Os2Version4Fields(..)
- , Os2Version5Fields(..)
- , OutlineFlag(..)
- , Panose(..)
- , PostFormat2Table(..)
- , PostHeader(..)
- , PostSubtable(..)
- , PostTable(..)
- , PrepTable(..)
- , RangeGaspBehavior(..)
- , SimpleGlyphDefinition(..)
- , TableDirectory(..)
- , TrueMaxpTable(..)
- , UVSOffset(..)
- , UVSMapping(..)
- , UnicodeValueRange(..)
- , VariationSelectorMap
- , unLocaTable
- , nameStringOffset
- ) where
-
-import Data.ByteString (ByteString)
-import Data.Int (Int8, Int16)
-import Data.IntMap (IntMap)
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Time (LocalTime(..))
-import Data.Vector (Vector)
-import Data.Word (Word8, Word16, Word32)
-import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), FWord, UFWord)
-
--- * Font directory
-
-data FontDirectory = FontDirectory
- { offsetSubtable :: OffsetSubtable
- , tableDirectory :: [TableDirectory]
- } deriving (Eq, Show)
-
-data OffsetSubtable = OffsetSubtable
- { scalerType :: Word32
- , numTables :: Int
- , searchRange :: Word16
- , entrySelector :: Word16
- , rangeShift :: Word16
- } deriving (Eq, Show)
-
-data TableDirectory = TableDirectory
- { tag :: ByteString
- , checkSum :: Word32
- , offset :: Int
- , length :: Int
- } deriving (Eq, Show)
-
--- * Name table
-
-data NameTable = NameTable
- { format :: Word16 -- ^ Format selector. Set to 0.
- , nameRecord :: [NameRecord] -- ^ The name records array.
- , variable :: [ByteString] -- ^ The character strings of the names.
- } deriving (Eq, Show)
-
-data NameRecord = NameRecord
- { platformID :: Word16 -- ^ Platform identifier code.
- , platformSpecificID :: Word16 -- ^ Platform-specific encoding identifier.
- , languageID :: Word16 -- ^ Language identifier.
- , nameID :: Word16 -- ^ Name identifier.
- , length :: Int -- ^ Name string length in bytes.
- , offset :: Int -- ^ Offset.
- } deriving (Eq, Show)
-
-nameStringOffset :: NameTable -> Word16
-nameStringOffset NameTable{..} =
- let nameRecordSize = 12
- precedingFieldsSize = 2 * 3
- in nameRecordSize * fromIntegral (Prelude.length nameRecord) + precedingFieldsSize
-
--- * 'cvt ' table
-
-newtype CVTable = CVTable [Int16]
- deriving (Eq, Show)
-
--- * Maximum profile table
-
-data TrueMaxpTable = TrueMaxpTable
- { version :: Fixed32 -- ^ 0x00010000 (1.0).
- , numGlyphs :: Word16 -- ^ The number of glyphs in the font.
- , maxPoints :: Word16 -- ^ Points in non-compound glyph.
- , maxContours :: Word16 -- ^ Contours in non-compound glyph.
- , maxComponentPoints :: Word16 -- ^ Points in compound glyph.
- , maxComponentContours :: Word16 -- ^ Contours in compound glyph.
- , maxZones :: Word16 -- ^ Set to 2.
- , maxTwilightPoints :: Word16 -- ^ Points used in Twilight Zone (Z0).
- , maxStorage :: Word16 -- ^ Number of Storage Area locations.
- , maxFunctionDefs :: Word16 -- ^ Number of FDEFs.
- , maxInstructionDefs :: Word16 -- ^ Number of IDEFs.
- , maxStackElements :: Word16 -- ^ Maximum stack depth.
- , maxSizeOfInstructions :: Word16 -- ^ Byte count for glyph instructions.
- , maxComponentElements :: Word16 -- ^ Number of glyphs referenced at top level.
- , maxComponentDepth :: Word16 -- ^ Levels of recursion, set to 0 if font has only simple glyphs.
- } deriving (Eq, Show)
-
-data OpenMaxpTable = OpenMaxpTable
- { version :: Fixed32 -- ^ 0x00005000 (0.5).
- , numGlyphs :: Word16 -- ^ The number of glyphs in the font.
- } deriving (Eq, Show)
-
-data MaxpTable = OpenMaxp OpenMaxpTable | TrueMaxp TrueMaxpTable
- deriving (Eq, Show)
-
--- * Horizontal header table
-
-data HheaTable = HheaTable
- { version :: Fixed32 -- ^ 0x00010000 (1.0).
- , ascent :: FWord -- ^ Distance from baseline of highest ascender.
- , descent :: FWord -- ^ Distance from baseline of lowest descender.
- , lineGap :: FWord -- ^ Typographic line gap.
- , advanceWidthMax :: UFWord -- ^ Must be consistent with horizontal metrics.
- , minLeftSideBearing :: FWord -- ^ Must be consistent with horizontal metrics.
- , minRightSideBearing :: FWord -- ^ Must be consistent with horizontal metrics.
- , xMaxExtent :: FWord -- ^ max(lsb + (xMax-xMin)).
- , caretSlopeRise :: Int16 -- ^ used to calculate the slope of the caret (rise/run) set to 1 for vertical caret.
- , caretSlopeRun :: Int16 -- ^ 0 for vertical.
- , caretOffset :: FWord -- ^ Set value to 0 for non-slanted fonts.
- , metricDataFormat :: Int16 -- ^ 0 for current format.
- , numOfLongHorMetrics :: Word16 -- ^ Number of advance widths in metrics table.
- } deriving (Eq, Show)
-
--- * Font header table
-
-data IndexToLocFormat
- = ShortOffsetIndexToLocFormat
- | LongOffsetIndexToLocFormat
- deriving (Eq, Show)
-
-data HeadTable = HeadTable
- { version :: Fixed32 -- ^ 0x00010000 if (version 1.0).
- , fontRevision :: Fixed32 -- ^ Set by font manufacturer.
- , checkSumAdjustment :: Word32 -- ^ To compute: set it to 0, calculate the checksum for the 'head' table and put it in the table directory, sum the entire font as a uint32_t, then store 0xB1B0AFBA - sum. (The checksum for the 'head' table will be wrong as a result. That is OK; do not reset it.)
- , magicNumber :: Word32 -- ^ Set to 0x5F0F3CF5.
- , flags :: Word16
- , unitsPerEm :: Word16 -- ^ Range from 64 to 16384.
- , created :: LocalTime -- ^ International date.
- , modified :: LocalTime -- ^ International date.
- , xMin :: Int16 -- ^ For all glyph bounding boxes.
- , yMin :: Int16 -- ^ For all glyph bounding boxes.
- , xMax :: Int16 -- ^ For all glyph bounding boxes.
- , yMax :: Int16 -- ^ For all glyph bounding boxes.
- , macStyle :: FontStyle
- , lowestRecPPEM :: Word16 -- ^ Smallest readable size in pixels.
- , fontDirectionHint :: FontDirectionHint -- ^ 0 Mixed directional glyphs.
- , indexToLocFormat :: IndexToLocFormat -- ^ 0 for short offsets, 1 for long.
- , glyphDataFormat :: Word16 -- ^ 0 for current format.
- } deriving (Eq, Show)
-
-data FontStyle = FontStyle
- { bold :: Bool
- , italic :: Bool
- , underline :: Bool
- , outline :: Bool
- , shadow :: Bool
- , condensed :: Bool
- , extended :: Bool
- } deriving (Eq, Show)
-
-data FontDirectionHint
- = MixedDirectionalGlyphs -- ^ 0. Mixed directional glyphs.
- | StronglyLeftToRightGlyphs -- ^ 1. Only strongly left to right glyphs.
- | LeftToRightGlyphsWithNeutrals -- ^ 2. Like 1 but also contains neutrals.
- | StronglyRightToLeftGlyphs -- ^ -1. Only strongly right to left glyphs.
- | RightToLeftGlyphsWithNeutrals -- ^ -2. Like -1 but also contains neutrals.
- deriving (Eq, Show)
-
-data LocaTable
- = ShortLocaTable (Vector Word16)
- | LongLocaTable (Vector Word32)
- deriving (Eq, Show)
-
-unLocaTable :: LocaTable -> Vector Word32
-unLocaTable (LongLocaTable values') = values'
-unLocaTable (ShortLocaTable values') = (* 2) . fromIntegral <$> values'
-
--- * Horizontal metrics table
-
-data LongHorMetric = LongHorMetric
- { advanceWidth :: Word16
- , leftSideBearing :: Int16
- } deriving (Eq, Show)
-
-data HmtxTable = HmtxTable
- { hMetrics :: NonEmpty LongHorMetric
- , leftSideBearing :: [Int16]
- } deriving (Eq, Show)
-
--- * Glyph name and PostScript font table
-
-data PostHeader = PostHeader
- { format :: Fixed32 -- ^ Format of this table
- , italicAngle :: Fixed32 -- ^ Italic angle in degrees
- , underlinePosition :: Int16 -- ^ Underline position
- , underlineThickness :: Int16 -- ^ Underline thickness
- , isFixedPitch :: Word32 -- ^ Font is monospaced; set to 1 if the font is monospaced and 0 otherwise (N.B., to maintain compatibility with older versions of the TrueType spec, accept any non-zero value as meaning that the font is monospaced)
- , minMemType42 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 42 font
- , maxMemType42 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 42 font
- , minMemType1 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 1 font
- , maxMemType1 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 1 font
- } deriving (Eq, Show)
-
-data PostFormat2Table = PostFormat2Table
- { glyphNameIndex :: Vector Word16 -- ^ Ordinal number of this glyph in 'post' string tables. This is not an offset.
- , names :: Vector ByteString
- } deriving (Eq, Show)
-
-data PostSubtable
- = None
- | PostFormat2 PostFormat2Table
- | PostFormat25 (Vector Int8)
- | PostFormat4 (Vector Word16)
- deriving (Eq, Show)
-
-data PostTable = PostTable
- { postHeader :: PostHeader
- , postSubtable :: PostSubtable
- } deriving (Eq, Show)
-
--- * Font program table
-
-newtype FpgmTable = FpgmTable (Vector Word8)
- deriving (Eq, Show)
-
--- * Prep table
-
-newtype PrepTable = PrepTable (Vector Word8)
- deriving (Eq, Show)
-
--- * Horizontal device metrics table
-
-data HdmxTable = HdmxTable
- { format :: Int16 -- ^ Format version number.
- , records :: [DeviceRecord]
- } deriving (Eq, Show)
-
-data DeviceRecord = DeviceRecord
- { pixelSize :: Word8 -- ^ Pixel size for following widths.
- , maximumWidth :: Word8 -- ^ Maximum width.
- , widths :: Vector Word8 -- ^ Widths.
- } deriving (Eq, Show)
-
--- * Glyph outline table
-
-data GlyphDescription = GlyphDescription
- { numberOfContours :: Int
- , xMin :: Int16 -- ^ Minimum x for coordinate data.
- , yMin :: Int16 -- ^ Minimum y for coordinate data.
- , xMax :: Int16 -- ^ Maximum x for coordinate data.
- , yMax :: Int16 -- ^ Maximum y for coordinate data.
- , definition :: GlyphDefinition
- } deriving (Eq, Show)
-
-data GlyphArgument
- = GlyphInt16Argument Int16
- | GlyphWord16Argument Word16
- | GlyphInt8Argument Int8
- | GlyphWord8Argument Word8
- deriving (Eq, Show)
-
-data GlyphTransformationOption
- = GlyphNoScale
- | GlyphScale F2Dot14
- | GlyphXyScale F2Dot14 F2Dot14
- | Glyph2By2Scale F2Dot14 F2Dot14 F2Dot14 F2Dot14
- deriving (Eq, Show)
-
-data SimpleGlyphDefinition = SimpleGlyphDefinition
- -- | Array of last points of each contour; n is the number of contours;
- -- array entries are point indices.
- { endPtsOfContours :: Vector Word16
- -- | Array of instructions for this glyph.
- , instructions :: Vector Word8
- -- Array of flags.
- , flags :: Vector OutlineFlag
- -- | Array of coordinates; the first is relative to (0,0), others are
- -- relative to previous point.
- , coordinates :: Vector GlyphCoordinate
- } deriving (Eq, Show)
-
-data CompoundGlyphDefinition = CompoundGlyphDefinition
- { components :: Vector ComponentGlyphPartDescription
- , instructions :: Vector Word8
- } deriving (Eq, Show)
-
-data GlyphDefinition
- = SimpleGlyph SimpleGlyphDefinition
- | CompoundGlyph CompoundGlyphDefinition
- deriving (Eq, Show)
-
-data ComponentGlyphFlags = ComponentGlyphFlags
- { roundXyToGrid :: Bool
- , weHaveInstructions :: Bool
- , useMyMetrics :: Bool
- , overlapCompound :: Bool
- } deriving (Eq, Show)
-
-data GlyphCoordinate = GlyphCoordinate
- { coordinateX :: Int16
- , coordinateY :: Int16
- } deriving (Eq, Show)
-
-instance Semigroup GlyphCoordinate
- where
- lhs <> rhs =
- let GlyphCoordinate{ coordinateX = lhX, coordinateY = lhY } = lhs
- GlyphCoordinate{ coordinateX = rhX, coordinateY = rhY } = rhs
- in GlyphCoordinate{ coordinateX = lhX + rhX, coordinateY = lhY + rhY }
-
-instance Monoid GlyphCoordinate
- where
- mempty = GlyphCoordinate 0 0
-
-data ComponentGlyphPartDescription = ComponentGlyphPartDescription
- { flags :: ComponentGlyphFlags
- , glyphIndex :: Word16
- , argument1 :: GlyphArgument
- , argument2 :: GlyphArgument
- , transformationOption :: GlyphTransformationOption
- } deriving (Eq, Show)
-
--- * Glyph outline table
-
-data OutlineFlag = OutlineFlag
- { onCurve :: Bool
- , xShortVector :: Bool
- , yShortVector :: Bool
- , repeat :: Word8
- , thisXIsSame :: Bool
- , thisYIsSame :: Bool
- } deriving (Eq, Show)
-
-newtype GlyfTable = GlyfTable (Vector GlyphDescription)
- deriving (Eq, Show)
-
--- 'cmap' table
-
--- | Character to glyph mapping table.
-data CmapTable = CmapTable
- { version :: Word16 -- ^ Version number is zero.
- -- | Encodings with an offset into subtables map.
- , encodings :: [CmapEncoding]
- -- ^ The key into the map is the offset in the 'CmapEncoding's.
- , subtables :: IntMap CmapSubtable
- } deriving (Eq, Show)
-
-data CmapEncoding = CmapEncoding
- { platformID :: Word16 -- ^ Platform identifier
- , platformSpecificID :: Word16 -- ^ Platform-specific encoding identifier.
- , offset :: Word32 -- ^ Offst of the mapping table.
- } deriving (Eq, Show)
-
-data CmapFormat0Table = CmapFormat0Table
- { language :: Word16 -- ^ Language code.
- , glyphIndexArray :: Vector Word8 -- ^ An array that maps character codes to glyph index values.
- } deriving (Eq, Show)
-
-data CmapFormat2Subheader = CmapFormat2Subheader
- { firstCode :: Word16
- , entryCount :: Word16
- , idDelta :: Int16
- , idRangeOffset :: Word16
- } deriving (Eq, Show)
-
-data CmapFormat2Table = CmapFormat2Table
- { language :: Word16 -- ^ Language code.
- , subHeaderKeys :: Vector Word16 -- ^ Array that maps high bytes to subHeaders: value is index * 8.
- , subHeaders :: Vector CmapFormat2Subheader -- ^ Variable length array of subHeader structures.
- , glyphIndexArray :: Vector Word16 -- ^ Variable length array containing subarrays.
- } deriving (Eq, Show)
-
-data CmapFormat4Table = CmapFormat4Table
- { language :: Word16 -- ^ Language code.
- , searchRange :: Word16 -- ^ 2 * (2**FLOOR(log2(segCount))).
- , entrySelector :: Word16 -- ^ log2(searchRange/2).
- , rangeShift :: Word16 -- ^ (2 * segCount) - searchRange.
- , endCode :: Vector Word16 -- ^ Ending character code for each segment, last = 0xFFFF.
- , startCode :: Vector Word16 -- ^ Starting character code for each segment.
- , idDelta :: Vector Word16 -- ^ Delta for all character codes in segment.
- , idRangeOffset :: Vector Word16 -- ^ Offset in bytes to glyph indexArray, or 0.
- , glyphIndexArray :: Vector Word16 -- ^ Glyph index array.
- } deriving (Eq, Show)
-
-data CmapFormat6Table = CmapFormat6Table
- { language :: Word16 -- ^ Language code.
- , firstCode :: Word16 -- ^ First character code of subrange.
- , glyphIndexArray :: Vector Word16 -- ^ Array of glyph index values for character codes in the range
- } deriving (Eq, Show)
-
-data CmapGroup = CmapGroup
- -- | First character code in this group; note that if this group is for one
- -- or more 16-bit character codes (which is determined from the is32 array),
- -- this 32-bit value will have the high 16-bits set to zero.
- { startCharCode :: Word32
- -- | Last character code in this group; same condition as listed above for
- -- the startCharCode.
- , endCharCode :: Word32
- -- | Glyph index corresponding to the starting character code.
- , startGlyphCode :: Word32
- } deriving (Eq, Show)
-
-data CmapFormat8Table = CmapFormat8Table
- { language :: Word32 -- ^ Language code.
- -- | Tightly packed array of bits (8K bytes total) indicating whether the
- -- particular 16-bit (index) value is the start of a 32-bit character code.
- , is32 :: [Word8]
- -- | Word32 Number of groupings which follow.
- , groups :: Vector CmapGroup
- } deriving (Eq, Show)
-
-data CmapFormat10Table = CmapFormat10Table
- { language :: Word32 -- ^ Language code.
- , startCharCode :: Word32 -- ^ First character code covered.
- , numChars :: Word32 -- ^ Number of character codes covered.
- , glyphs :: Vector Word16 -- ^ Array of glyph indices for the character codes covered.
- } deriving (Eq, Show)
-
-data CmapFormat12Table = CmapFormat12Table
- { language :: Word32 -- ^ Language code.
- , groups :: Vector CmapGroup
- } deriving (Eq, Show)
-
-type CmapFormat13Table = CmapFormat12Table
-
-newtype CmapFormat14Table = CmapFormat14Table
- { varSelectorRecords :: VariationSelectorMap
- } deriving (Eq, Show)
-
-data CmapSubtable
- = CmapFormat0 CmapFormat0Table
- | CmapFormat2 CmapFormat2Table
- | CmapFormat4 CmapFormat4Table
- | CmapFormat6 CmapFormat6Table
- | CmapFormat8 CmapFormat8Table
- | CmapFormat10 CmapFormat10Table
- | CmapFormat12 CmapFormat12Table
- | CmapFormat13 CmapFormat13Table
- | CmapFormat14 CmapFormat14Table
- deriving (Eq, Show)
-
-data UVSOffset a b = DefaultUVSOffset Word32 a | NonDefaultUVSOffset Word32 b
- deriving (Eq, Show)
-
-data UVSMapping = UVSMapping
- { unicodeValue :: Word32 -- ^ Base Unicode value of the UVS.
- , glyphID :: Word16 -- ^ Glyph ID of the UVS.
- } deriving (Eq, Show)
-
-data UnicodeValueRange = UnicodeValueRange
- { startUnicodeValue :: Word32 -- ^ First value in this range.
- , additionalCount :: Word8 -- ^ Number of additional values in this range.
- } deriving (Eq, Show)
-
--- | Mapping from variation selector record offsets to the record data.
-type VariationSelectorMap = IntMap
- (NonEmpty (UVSOffset (Vector UnicodeValueRange) (Vector UVSMapping)))
-
--- * OS/2 table
-
-data Os2Table
- = Os2Version0 Os2BaseFields (Maybe Os2MicrosoftFields)
- | Os2Version1 Os2BaseFields Os2MicrosoftFields Os2Version1Fields
- | Os2Version2 Os2BaseFields Os2MicrosoftFields Os2Version4Fields
- | Os2Version3 Os2BaseFields Os2MicrosoftFields Os2Version4Fields
- | Os2Version4 Os2BaseFields Os2MicrosoftFields Os2Version4Fields
- | Os2Version5 Os2BaseFields Os2MicrosoftFields Os2Version5Fields
- deriving (Eq, Show)
-
-data Os2Version1Fields = Os2Version1Fields
- { ulCodePageRange1 :: Word32
- , ulCodePageRange2 :: Word32
- } deriving (Eq, Show)
-
-data Os2MicrosoftFields = Os2MicrosoftFields
- { sTypoAscender :: Int16
- , sTypoDescender :: Int16
- , sTypoLineGap :: Int16
- , usWinAscent :: Word16
- , usWinDescent :: Word16
- } deriving (Eq, Show)
-
-data Os2Version4Fields = Os2Version4Fields
- { ulCodePageRange1 :: Word32
- , ulCodePageRange2 :: Word32
- , sxHeight :: Int16
- , sCapHeight :: Int16
- , usDefaultChar :: Word16
- , usBreakChar :: Word16
- , usMaxContext :: Word16
- } deriving (Eq, Show)
-
-data Os2Version5Fields = Os2Version5Fields
- { ulCodePageRange1 :: Word32
- , ulCodePageRange2 :: Word32
- , sxHeight :: Int16
- , sCapHeight :: Int16
- , usDefaultChar :: Word16
- , usBreakChar :: Word16
- , usMaxContext :: Word16
- , usLowerOpticalPointSize :: Word16
- , usUpperOpticalPointSize :: Word16
- } deriving (Eq, Show)
-
-data Os2BaseFields = Os2BaseFields
- { version :: Word16 -- ^ Table version number (set to 0).
- -- | Average weighted advance width of lower case letters and space.
- , xAvgCharWidth :: Int16
- -- | Visual weight (degree of blackness or thickness) of stroke in glyphs.
- , usWeightClass :: Word16
- -- | Relative change from the normal aspect ratio (width to height ratio)
- -- as specified by a font designer for the glyphs in the font.
- , usWidthClass :: Word16
- -- | Characteristics and properties of this font (set undefined bits to
- -- zero).
- , fsType :: Int16
- -- | Recommended horizontal size in pixels for subscripts.
- , ySubscriptXSize :: Int16
- -- | Recommended vertical size in pixels for subscripts.
- , ySubscriptYSize :: Int16
- -- | Recommended horizontal offset for subscripts.
- , ySubscriptXOffset :: Int16
- -- | Recommended vertical offset form the baseline for subscripts.
- , ySubscriptYOffset :: Int16
- -- | Recommended horizontal size in pixels for superscripts.
- , ySuperscriptXSize :: Int16
- -- | Recommended vertical size in pixels for superscripts.
- , ySuperscriptYSize :: Int16
- -- | Recommended horizontal offset for superscripts.
- , ySuperscriptXOffset :: Int16
- -- | Recommended vertical offset from the baseline for superscripts.
- , ySuperscriptYOffset :: Int16
- -- | Width of the strikeout stroke.
- , yStrikeoutSize :: Int16
- -- | Position of the strikeout stroke relative to the baseline.
- , yStrikeoutPosition :: Int16
- -- ^ Classification of font-family design.
- , sFamilyClass :: Int16
- -- | 10 byte series of number used to describe the visual characteristics
- -- of a given typeface.
- , panose :: Panose
- -- | Field is split into two bit fields of 96 and 36 bits each. The low 96
- -- bits are used to specify the Unicode blocks encompassed by the font file.
- -- The high 32 bits are used to specify the character or script sets covered
- -- by the font file. Bit assignments are pending. Set to 0.
- , ulUnicodeRange :: Vector Word32
- -- | Four character identifier for the font vendor.
- , achVendID :: Vector Int8
- -- | 2-byte bit field containing information concerning the nature of the
- -- font patterns.
- , fsSelection :: Word16
- -- | The minimum Unicode index in this font.
- , fsFirstCharIndex :: Word16
- -- | The maximum Unicode index in this font.
- , fsLastCharIndex :: Word16
- } deriving (Eq, Show)
-
-data Panose = Panose
- { bFamilyType :: BFamilyType
- , bSerifStyle :: BSerifStyle
- , bWeight :: BWeight
- , bProportion :: BProportion
- , bContrast :: BContrast
- , bStrokeVariation :: BStrokeVariation
- , bArmStyle :: BArmStyle
- , bLetterform :: BLetterform
- , bMidline :: BMidline
- , bXHeight :: BXHeight
- } deriving (Eq, Show)
-
-data BFamilyType
- = AnyFamilyType
- | NoFitFamilyType
- | TextAndDisplayFamilyType
- | ScriptFamilyType
- | DecorativeFamilyType
- | PictorialFamilyType
- deriving Eq
-
-instance Show BFamilyType
- where
- show AnyFamilyType = "Any"
- show NoFitFamilyType = "No Fit"
- show TextAndDisplayFamilyType = "Text and Display"
- show ScriptFamilyType = "Script"
- show DecorativeFamilyType = "Decorative"
- show PictorialFamilyType = "Pictorial"
-
-instance Enum BFamilyType
- where
- toEnum 0 = AnyFamilyType
- toEnum 1 = NoFitFamilyType
- toEnum 2 = TextAndDisplayFamilyType
- toEnum 3 = ScriptFamilyType
- toEnum 4 = DecorativeFamilyType
- toEnum 5 = PictorialFamilyType
- toEnum _ = error "Unknown family type"
- fromEnum AnyFamilyType = 0
- fromEnum NoFitFamilyType = 1
- fromEnum TextAndDisplayFamilyType = 2
- fromEnum ScriptFamilyType = 3
- fromEnum DecorativeFamilyType = 4
- fromEnum PictorialFamilyType = 5
-
-data BSerifStyle
- = AnySerifStyle
- | NoFitSerifStyle
- | CoveSerifStyle
- | ObtuseCoveSerifStyle
- | SquareCoveSerifStyle
- | ObtuseSquareCoveSerifStyle
- | SquareSerifStyle
- | ThinSerifStyle
- | BoneSerifStyle
- | ExaggeratedSerifStyle
- | TriangleSerifStyle
- | NormalSansSerifStyle
- | ObtuseSansSerifStyle
- | PerpSansSerifStyle
- | FlaredSerifStyle
- | RoundedSerifStyle
- deriving Eq
-
-instance Show BSerifStyle
- where
- show AnySerifStyle = "Any"
- show NoFitSerifStyle = "No Fit"
- show CoveSerifStyle = "Cove"
- show ObtuseCoveSerifStyle = "Obtuse Cove"
- show SquareCoveSerifStyle = "Square Cove"
- show ObtuseSquareCoveSerifStyle = "Obtuse Square Cove"
- show SquareSerifStyle = "Square"
- show ThinSerifStyle = "Thin"
- show BoneSerifStyle = "Bone"
- show ExaggeratedSerifStyle = "Exaggerated"
- show TriangleSerifStyle = "Triangle"
- show NormalSansSerifStyle = "Normal Sans"
- show ObtuseSansSerifStyle = "Obtuse Sans"
- show PerpSansSerifStyle = "Perp Sans"
- show FlaredSerifStyle = "Flared"
- show RoundedSerifStyle = "Rounded"
-
-instance Enum BSerifStyle
- where
- toEnum 0 = AnySerifStyle
- toEnum 1 = NoFitSerifStyle
- toEnum 2 = CoveSerifStyle
- toEnum 3 = ObtuseCoveSerifStyle
- toEnum 4 = SquareCoveSerifStyle
- toEnum 5 = ObtuseSquareCoveSerifStyle
- toEnum 6 = SquareSerifStyle
- toEnum 7 = ThinSerifStyle
- toEnum 8 = BoneSerifStyle
- toEnum 9 = ExaggeratedSerifStyle
- toEnum 10 = TriangleSerifStyle
- toEnum 11 = NormalSansSerifStyle
- toEnum 12 = ObtuseSansSerifStyle
- toEnum 13 = PerpSansSerifStyle
- toEnum 14 = FlaredSerifStyle
- toEnum 15 = RoundedSerifStyle
- toEnum _ = error "Unknown serif type"
- fromEnum AnySerifStyle = 0
- fromEnum NoFitSerifStyle = 1
- fromEnum CoveSerifStyle = 2
- fromEnum ObtuseCoveSerifStyle = 3
- fromEnum SquareCoveSerifStyle = 4
- fromEnum ObtuseSquareCoveSerifStyle = 5
- fromEnum SquareSerifStyle = 6
- fromEnum ThinSerifStyle = 7
- fromEnum BoneSerifStyle = 8
- fromEnum ExaggeratedSerifStyle = 9
- fromEnum TriangleSerifStyle = 10
- fromEnum NormalSansSerifStyle = 11
- fromEnum ObtuseSansSerifStyle = 12
- fromEnum PerpSansSerifStyle = 13
- fromEnum FlaredSerifStyle = 14
- fromEnum RoundedSerifStyle = 15
-
-data BWeight
- = AnyWeight
- | NoFitWeight
- | VeryLightWeight
- | LightWeight
- | ThinWeight
- | BookWeight
- | MediumWeight
- | DemiWeight
- | BoldWeight
- | HeavyWeight
- | BlackWeight
- | NordWeight
- deriving Eq
-
-instance Show BWeight
- where
- show AnyWeight = "Any"
- show NoFitWeight = "No Fit"
- show VeryLightWeight = "Very Light"
- show LightWeight = "Light"
- show ThinWeight = "Thin"
- show BookWeight = "Book"
- show MediumWeight = "Medium"
- show DemiWeight = "Demi"
- show BoldWeight = "Bold"
- show HeavyWeight = "Heavy"
- show BlackWeight = "Black"
- show NordWeight = "Nord"
-
-instance Enum BWeight
- where
- fromEnum AnyWeight = 0
- fromEnum NoFitWeight = 1
- fromEnum VeryLightWeight = 2
- fromEnum LightWeight = 3
- fromEnum ThinWeight = 4
- fromEnum BookWeight = 5
- fromEnum MediumWeight = 6
- fromEnum DemiWeight = 7
- fromEnum BoldWeight = 8
- fromEnum HeavyWeight = 9
- fromEnum BlackWeight = 10
- fromEnum NordWeight = 11
- toEnum 0 = AnyWeight
- toEnum 1 = NoFitWeight
- toEnum 2 = VeryLightWeight
- toEnum 3 = LightWeight
- toEnum 4 = ThinWeight
- toEnum 5 = BookWeight
- toEnum 6 = MediumWeight
- toEnum 7 = DemiWeight
- toEnum 8 = BoldWeight
- toEnum 9 = HeavyWeight
- toEnum 10 = BlackWeight
- toEnum 11 = NordWeight
- toEnum _ = error "Unknown weight"
-
-data BProportion
- = AnyProportion
- | NoFitProportion
- | OldStyleProportion
- | ModernProportion
- | EvenWidthProportion
- | ExpandedProportion
- | CondensedProportion
- | VeryExpandedProportion
- | VeryCondensedProportion
- | MonospacedProportion
- deriving Eq
-
-instance Show BProportion
- where
- show AnyProportion = "Any"
- show NoFitProportion = "No Fit"
- show OldStyleProportion = "Old Style"
- show ModernProportion = "Modern"
- show EvenWidthProportion = "Even Width"
- show ExpandedProportion = "Expanded"
- show CondensedProportion = "Condensed"
- show VeryExpandedProportion = "Very Expanded"
- show VeryCondensedProportion = "Very Condensed"
- show MonospacedProportion = "Monospaced"
-
-instance Enum BProportion
- where
- fromEnum AnyProportion = 0
- fromEnum NoFitProportion = 1
- fromEnum OldStyleProportion = 2
- fromEnum ModernProportion = 3
- fromEnum EvenWidthProportion = 4
- fromEnum ExpandedProportion = 5
- fromEnum CondensedProportion = 6
- fromEnum VeryExpandedProportion = 7
- fromEnum VeryCondensedProportion = 8
- fromEnum MonospacedProportion = 9
- toEnum 0 = AnyProportion
- toEnum 1 = NoFitProportion
- toEnum 2 = OldStyleProportion
- toEnum 3 = ModernProportion
- toEnum 4 = EvenWidthProportion
- toEnum 5 = ExpandedProportion
- toEnum 6 = CondensedProportion
- toEnum 7 = VeryExpandedProportion
- toEnum 8 = VeryCondensedProportion
- toEnum 9 = MonospacedProportion
- toEnum _ = error "Unknown proportion"
-
-data BContrast
- = AnyContrast
- | NoFitContrast
- | NoneContrast
- | VeryLowContrast
- | LowContrast
- | MediumLowContrast
- | MediumContrast
- | MediumHighContrast
- | HighContrast
- | VeryHighContrast
- deriving Eq
-
-instance Show BContrast
- where
- show AnyContrast = "Any"
- show NoFitContrast = "No Fit"
- show NoneContrast = "None"
- show VeryLowContrast = "Very Low"
- show LowContrast = "Low"
- show MediumLowContrast = "Medium Low"
- show MediumContrast = "Medium"
- show MediumHighContrast = "Medium High"
- show HighContrast = "High"
- show VeryHighContrast = "Very High"
-
-instance Enum BContrast
- where
- fromEnum AnyContrast = 0
- fromEnum NoFitContrast = 1
- fromEnum NoneContrast = 2
- fromEnum VeryLowContrast = 3
- fromEnum LowContrast = 4
- fromEnum MediumLowContrast = 5
- fromEnum MediumContrast = 6
- fromEnum MediumHighContrast = 7
- fromEnum HighContrast = 8
- fromEnum VeryHighContrast = 9
- toEnum 0 = AnyContrast
- toEnum 1 = NoFitContrast
- toEnum 2 = NoneContrast
- toEnum 3 = VeryLowContrast
- toEnum 4 = LowContrast
- toEnum 5 = MediumLowContrast
- toEnum 6 = MediumContrast
- toEnum 7 = MediumHighContrast
- toEnum 8 = HighContrast
- toEnum 9 = VeryHighContrast
- toEnum _ = error "Unknown contrast"
-
-data BStrokeVariation
- = AnyStrokeVariation
- | NoFitStrokeVariation
- | GradualDiagonalStrokeVariation
- | GradualTransitionalStrokeVariation
- | GradualVerticalStrokeVariation
- | GradualHorizontalStrokeVariation
- | RapidVerticalStrokeVariation
- | RapidHorizontalStrokeVariation
- | InstantVerticalStrokeVariation
- deriving Eq
-
-instance Show BStrokeVariation
- where
- show AnyStrokeVariation = "Any"
- show NoFitStrokeVariation = "No Fit"
- show GradualDiagonalStrokeVariation = "Gradual/Diagonal"
- show GradualTransitionalStrokeVariation = "Gradual/Transitional"
- show GradualVerticalStrokeVariation = "Gradual/Vertical"
- show GradualHorizontalStrokeVariation = "Gradual/Horizontal"
- show RapidVerticalStrokeVariation = "Rapid/Vertical"
- show RapidHorizontalStrokeVariation = "Rapid/Horizontal"
- show InstantVerticalStrokeVariation = "Instant/Vertical"
-
-instance Enum BStrokeVariation
- where
- fromEnum AnyStrokeVariation = 0
- fromEnum NoFitStrokeVariation = 1
- fromEnum GradualDiagonalStrokeVariation = 2
- fromEnum GradualTransitionalStrokeVariation = 3
- fromEnum GradualVerticalStrokeVariation = 4
- fromEnum GradualHorizontalStrokeVariation = 5
- fromEnum RapidVerticalStrokeVariation = 6
- fromEnum RapidHorizontalStrokeVariation = 7
- fromEnum InstantVerticalStrokeVariation = 8
- toEnum 0 = AnyStrokeVariation
- toEnum 1 = NoFitStrokeVariation
- toEnum 2 = GradualDiagonalStrokeVariation
- toEnum 3 = GradualTransitionalStrokeVariation
- toEnum 4 = GradualVerticalStrokeVariation
- toEnum 5 = GradualHorizontalStrokeVariation
- toEnum 6 = RapidVerticalStrokeVariation
- toEnum 7 = RapidHorizontalStrokeVariation
- toEnum 8 = InstantVerticalStrokeVariation
- toEnum _ = error "Unknown stroke variation"
-
-data BArmStyle
- = AnyArmStyle
- | NoFitArmStyle
- | StraightArmsHorizontalArmStyle
- | StraightArmsWedgeArmStyle
- | StraightArmsVerticalArmStyle
- | StraightArmsSingleSerifArmStyle
- | StraightArmsDoubleSerifArmStyle
- | NonStraightArmsHorizontalArmStyle
- | NonStraightArmsWedgeArmStyle
- | NonStraightArmsVerticalArmStyle
- | NonStraightArmsSingleSerifArmStyle
- | NonStraightArmsDoubleSerifArmStyle
- deriving Eq
-
-instance Show BArmStyle
- where
- show AnyArmStyle = "Any"
- show NoFitArmStyle = "No Fit"
- show StraightArmsHorizontalArmStyle = "Straight Arms/Horizontal"
- show StraightArmsWedgeArmStyle = "Straight Arms/Wedge"
- show StraightArmsVerticalArmStyle = "Straight Arms/Vertical"
- show StraightArmsSingleSerifArmStyle = "Straight Arms/Single Serif"
- show StraightArmsDoubleSerifArmStyle = "Straight Arms/Double Serif"
- show NonStraightArmsHorizontalArmStyle = "Non-Straight Arms/Horizontal"
- show NonStraightArmsWedgeArmStyle = "Non-Straight Arms/Wedge"
- show NonStraightArmsVerticalArmStyle = "Non-Straight Arms/Vertical"
- show NonStraightArmsSingleSerifArmStyle = "Non-Straight Arms/Single Serif"
- show NonStraightArmsDoubleSerifArmStyle = "Non-Straight Arms/Double Serif"
-
-instance Enum BArmStyle
- where
- fromEnum AnyArmStyle = 0
- fromEnum NoFitArmStyle = 1
- fromEnum StraightArmsHorizontalArmStyle = 2
- fromEnum StraightArmsWedgeArmStyle = 3
- fromEnum StraightArmsVerticalArmStyle = 4
- fromEnum StraightArmsSingleSerifArmStyle = 5
- fromEnum StraightArmsDoubleSerifArmStyle = 6
- fromEnum NonStraightArmsHorizontalArmStyle = 7
- fromEnum NonStraightArmsWedgeArmStyle = 8
- fromEnum NonStraightArmsVerticalArmStyle = 9
- fromEnum NonStraightArmsSingleSerifArmStyle = 10
- fromEnum NonStraightArmsDoubleSerifArmStyle = 11
- toEnum 0 = AnyArmStyle
- toEnum 1 = NoFitArmStyle
- toEnum 2 = StraightArmsHorizontalArmStyle
- toEnum 3 = StraightArmsWedgeArmStyle
- toEnum 4 = StraightArmsVerticalArmStyle
- toEnum 5 = StraightArmsSingleSerifArmStyle
- toEnum 6 = StraightArmsDoubleSerifArmStyle
- toEnum 7 = NonStraightArmsHorizontalArmStyle
- toEnum 8 = NonStraightArmsWedgeArmStyle
- toEnum 9 = NonStraightArmsVerticalArmStyle
- toEnum 10 = NonStraightArmsSingleSerifArmStyle
- toEnum 11 = NonStraightArmsDoubleSerifArmStyle
- toEnum _ = error "Unknown arm style"
-
-data BLetterform
- = AnyLetterform
- | NoFitLetterform
- | NormalContactLetterform
- | NormalWeightedLetterform
- | NormalBoxedLetterform
- | NormalFlattenedLetterform
- | NormalRoundedLetterform
- | NormalOffCenterLetterform
- | NormalSquareLetterform
- | ObliqueContactLetterform
- | ObliqueWeightedLetterform
- | ObliqueBoxedLetterform
- | ObliqueFlattenedLetterform
- | ObliqueRoundedLetterform
- | ObliqueOffCenterLetterform
- | ObliqueSquareLetterform
- deriving Eq
-
-instance Show BLetterform
- where
- show AnyLetterform = "Any"
- show NoFitLetterform = "No Fit"
- show NormalContactLetterform = "Normal/Contact"
- show NormalWeightedLetterform = "Normal/Weighted"
- show NormalBoxedLetterform = "Normal/Boxed"
- show NormalFlattenedLetterform = "Normal/Flattened"
- show NormalRoundedLetterform = "Normal/Rounded"
- show NormalOffCenterLetterform = "Normal/Off Center"
- show NormalSquareLetterform = "Normal/Square"
- show ObliqueContactLetterform = "Oblique/Contact"
- show ObliqueWeightedLetterform = "Oblique/Weighted"
- show ObliqueBoxedLetterform = "Oblique/Boxed"
- show ObliqueFlattenedLetterform = "Oblique/Flattened"
- show ObliqueRoundedLetterform = "Oblique/Rounded"
- show ObliqueOffCenterLetterform = "Oblique/Off Center"
- show ObliqueSquareLetterform = "Oblique/Square"
-
-instance Enum BLetterform
- where
- fromEnum AnyLetterform = 0
- fromEnum NoFitLetterform = 1
- fromEnum NormalContactLetterform = 2
- fromEnum NormalWeightedLetterform = 3
- fromEnum NormalBoxedLetterform = 4
- fromEnum NormalFlattenedLetterform = 5
- fromEnum NormalRoundedLetterform = 6
- fromEnum NormalOffCenterLetterform = 7
- fromEnum NormalSquareLetterform = 8
- fromEnum ObliqueContactLetterform = 9
- fromEnum ObliqueWeightedLetterform = 10
- fromEnum ObliqueBoxedLetterform = 11
- fromEnum ObliqueFlattenedLetterform = 12
- fromEnum ObliqueRoundedLetterform = 13
- fromEnum ObliqueOffCenterLetterform = 14
- fromEnum ObliqueSquareLetterform = 15
- toEnum 0 = AnyLetterform
- toEnum 1 = NoFitLetterform
- toEnum 2 = NormalContactLetterform
- toEnum 3 = NormalWeightedLetterform
- toEnum 4 = NormalBoxedLetterform
- toEnum 5 = NormalFlattenedLetterform
- toEnum 6 = NormalRoundedLetterform
- toEnum 7 = NormalOffCenterLetterform
- toEnum 8 = NormalSquareLetterform
- toEnum 9 = ObliqueContactLetterform
- toEnum 10 = ObliqueWeightedLetterform
- toEnum 11 = ObliqueBoxedLetterform
- toEnum 12 = ObliqueFlattenedLetterform
- toEnum 13 = ObliqueRoundedLetterform
- toEnum 14 = ObliqueOffCenterLetterform
- toEnum 15 = ObliqueSquareLetterform
- toEnum _ = error "Unknown letterform"
-
-data BMidline
- = AnyMidline
- | NoFitMidline
- | StandardTrimmedMidline
- | StandardPointedMidline
- | StandardSerifedMidline
- | HighTrimmedMidline
- | HighPointedMidline
- | HighSerifedMidline
- | ConstantTrimmedMidline
- | ConstantPointedMidline
- | ConstantSerifedMidline
- | LowTrimmedMidline
- | LowPointedMidline
- | LowSerifedMidline
- deriving Eq
-
-instance Show BMidline
- where
- show AnyMidline = "Any"
- show NoFitMidline = "No Fit"
- show StandardTrimmedMidline = "Standard/Trimmed"
- show StandardPointedMidline = "Standard/Pointed"
- show StandardSerifedMidline = "Standard/Serifed"
- show HighTrimmedMidline = "High/Trimmed"
- show HighPointedMidline = "High/Pointed"
- show HighSerifedMidline = "High/Serifed"
- show ConstantTrimmedMidline = "Constant/Trimmed"
- show ConstantPointedMidline = "Constant/Pointed"
- show ConstantSerifedMidline = "Constant/Serifed"
- show LowTrimmedMidline = "Low/Trimmed"
- show LowPointedMidline = "Low/Pointed"
- show LowSerifedMidline = "Low/Serifed"
-
-instance Enum BMidline
- where
- fromEnum AnyMidline = 0
- fromEnum NoFitMidline = 1
- fromEnum StandardTrimmedMidline = 2
- fromEnum StandardPointedMidline = 3
- fromEnum StandardSerifedMidline = 4
- fromEnum HighTrimmedMidline = 5
- fromEnum HighPointedMidline = 6
- fromEnum HighSerifedMidline = 7
- fromEnum ConstantTrimmedMidline = 8
- fromEnum ConstantPointedMidline = 9
- fromEnum ConstantSerifedMidline = 10
- fromEnum LowTrimmedMidline = 11
- fromEnum LowPointedMidline = 12
- fromEnum LowSerifedMidline = 13
- toEnum 0 = AnyMidline
- toEnum 1 = NoFitMidline
- toEnum 2 = StandardTrimmedMidline
- toEnum 3 = StandardPointedMidline
- toEnum 4 = StandardSerifedMidline
- toEnum 5 = HighTrimmedMidline
- toEnum 6 = HighPointedMidline
- toEnum 7 = HighSerifedMidline
- toEnum 8 = ConstantTrimmedMidline
- toEnum 9 = ConstantPointedMidline
- toEnum 10 = ConstantSerifedMidline
- toEnum 11 = LowTrimmedMidline
- toEnum 12 = LowPointedMidline
- toEnum 13 = LowSerifedMidline
- toEnum _ = error "Unknown midline"
-
-data BXHeight
- = AnyXHeight
- | NoFitXHeight
- | ConstantSmallXHeight
- | ConstantStandardXHeight
- | ConstantLargeXHeight
- | DuckingSmallXHeight
- | DuckingStandardXHeight
- | DuckingLargeXHeight
- deriving Eq
-
-instance Show BXHeight
- where
- show AnyXHeight = "Any"
- show NoFitXHeight = "No Fit"
- show ConstantSmallXHeight = "Constant/Small"
- show ConstantStandardXHeight = "Constant/Standard"
- show ConstantLargeXHeight = "Constant/Large"
- show DuckingSmallXHeight = "Ducking/Small"
- show DuckingStandardXHeight = "Ducking/Standard"
- show DuckingLargeXHeight = "Ducking/Large"
-
-instance Enum BXHeight
- where
- fromEnum AnyXHeight = 0
- fromEnum NoFitXHeight = 1
- fromEnum ConstantSmallXHeight = 2
- fromEnum ConstantStandardXHeight = 3
- fromEnum ConstantLargeXHeight = 4
- fromEnum DuckingSmallXHeight = 5
- fromEnum DuckingStandardXHeight = 6
- fromEnum DuckingLargeXHeight = 7
- toEnum 0 = AnyXHeight
- toEnum 1 = NoFitXHeight
- toEnum 2 = ConstantSmallXHeight
- toEnum 3 = ConstantStandardXHeight
- toEnum 4 = ConstantLargeXHeight
- toEnum 5 = DuckingSmallXHeight
- toEnum 6 = DuckingStandardXHeight
- toEnum 7 = DuckingLargeXHeight
- toEnum _ = error "Unknown X height"
-
--- * Kern table
-
-newtype KernHeader = KernHeader
- { version :: Fixed32 -- ^ The version number of the kerning table (0x00010000 for the current version).
- } deriving (Eq, Show)
-
-data KernSubtableHeader = KernSubtableHeader
- -- | The length of this subtable in bytes, including this header.
- { length :: Word32
- -- | Circumstances under which this table is used.
- , coverage :: [Coverage]
- -- | The tuple index (used for variations fonts). This value specifies which
- -- tuple this subtable covers.
- , tupleIndex :: Word16
- } deriving (Eq, Show)
-
-data Coverage
- = KernVertical -- ^ Set if table has vertical kerning values.
- | KernCrossStream -- ^ Set if table has cross-stream kerning values.
- | KernVariation -- ^ Set if table has variation kerning values.
- | KernUnusedBits -- ^ Set to 0.
- | KernFormatMask -- ^ Set the format of this subtable (0-3 currently defined).
- deriving (Eq, Show)
-
-data KernFormat0Pair = KernFormat0Pair
- { left :: Word16 -- ^ The glyph index for the lefthand glyph in the kerning pair.
- , right :: Word16 -- ^ The glyph index for the righthand glyph in the kerning pair.
- -- | The kerning value in FUnits for the left and right pair in FUnits.
- -- If this value is greater than zero, the glyphs are moved apart.
- -- If this value is less than zero, the glyphs are moved together.
- , value :: Int16
- } deriving (Eq, Show)
-
-data KernFormat0Table = KernFormat0Table
- -- | The largest power of two less than or equal to the value of nPairs,
- -- multiplied by the size in bytes of an entry in the subtable.
- { searchRange :: Word16
- -- | This is calculated as log2 of the largest power of two less than or
- -- equal to the value of nPairs. This value indicates how many iterations of
- -- the search loop have to be made. For example, in a list of eight items,
- -- there would be three iterations of the loop.
- , entrySelector :: Word16
- -- | The value of nPairs minus the largest power of two less than or equal
- -- to nPairs. This is multiplied by the size in bytes of an entry in the
- -- table.
- , rangeShift :: Word16
- , pairs :: [KernFormat0Pair]
- } deriving (Eq, Show)
-
--- | Kern subtable format 1 header.
-data StateHeader = StateHeader
- { stateSize :: Word16 -- ^ Number of classes defined for this table.
- -- | Offset from the beginning of the state table to the beginning of the
- -- class subtable.
- , classTableOffset :: Word16
- -- | Offset from the beginning of the state table to the beginning of the
- -- state array.
- , stateArrayOffset :: Word16
- -- | Offset from the beginning of the state table to the beginning of the
- -- entry subtable.
- , entryTableOffset :: Word16
- -- | Offset from the beginning of the state table to the beginning of the
- -- state table values.
- , valueOffset :: Word16
- } deriving (Eq, Show)
-
-data StateEntry = StateEntry
- { newState :: Word16
- , flags :: Word16
- } deriving (Eq, Show)
-
-data KernFormat1Table = KernFormat1Table
- { stateHeader :: StateHeader
- , firstGlyph :: Word16
- , classArray :: ByteString
- , stateArray :: ByteString
- , entries :: [StateEntry]
- } deriving (Eq, Show)
-
-data SimpleArrayHeader = SimpleArrayHeader
- { rowWidth :: Word16 -- ^ The width, in bytes, of a row in the subtable.
- -- | Offset from beginning of this subtable to the left-hand offset table.
- , leftOffsetTable :: Word16
- -- | Offset from beginning of this subtable to right-hand offset table.
- , rightOffsetTable :: Word16
- -- | Offset from beginning of this subtable to the start of the kerning
- -- array.
- , array :: Word16
- } deriving (Eq, Show)
-
-data ClassTableHeader = ClassTableHeader
- { firstGlyph -- ^ First glyph in class range.
- -- | The offsets array for all of the glyphs in the range.
- , offsets :: [Word16]
- } deriving (Eq, Show)
-
-data KernFormat2Table = KernFormat2Table
- { simpleArrayHeader :: SimpleArrayHeader
- , classTableHeader :: ClassTableHeader
- , values :: [Int16]
- } deriving (Eq, Show)
-
--- * 'gasp' table
-
--- | Grid-fitting And Scan-conversion Procedure.
-data GASPTable = GASPTable
- { version :: Word16 -- ^ Version number (set to 0).
- , gaspRange :: [GASPRange] -- ^ Sorted by ppem.
- } deriving (Eq, Show)
-
-data GASPRange = GASPRange
- { rangeMaxPPEM :: Word16 -- ^ Upper limit of range, in PPEM.
- , rangeGaspBehavior :: Word16 -- ^ Flags describing desired rasterizer behavior.
- } deriving (Eq, Show)
-
-data RangeGaspBehavior
- = KGASPGridFit -- ^ Use gridfitting.
- | KGASPDoGray -- ^ Use grayscale rendering.
- deriving (Eq, Show)
-
-instance Enum RangeGaspBehavior
- where
- toEnum 1 = KGASPGridFit
- toEnum 2 = KGASPDoGray
- toEnum _ = error "Unknown range GASP behavior"
- fromEnum KGASPGridFit = 1
- fromEnum KGASPDoGray = 2
diff --git a/src/Graphics/Fountainhead/Type.hs b/src/Graphics/Fountainhead/Type.hs
deleted file mode 100644
index e809d9c..0000000
--- a/src/Graphics/Fountainhead/Type.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{- 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
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:25:13 +0000