From a34b46e1b553623d5dc385fc8e235df808fbadb2 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 3 Feb 2024 11:58:47 +0100 Subject: Add font compression --- app/Main.hs | 64 +- fountainhead.cabal | 15 +- lib/Graphics/Fountainhead.hs | 49 ++ lib/Graphics/Fountainhead/Compression.hs | 27 + lib/Graphics/Fountainhead/Dumper.hs | 854 +++++++++++++++++++ lib/Graphics/Fountainhead/Parser.hs | 1244 ++++++++++++++++++++++++++++ lib/Graphics/Fountainhead/TrueType.hs | 1318 ++++++++++++++++++++++++++++++ lib/Graphics/Fountainhead/Type.hs | 41 + src/Graphics/Fountainhead.hs | 50 -- src/Graphics/Fountainhead/Dumper.hs | 847 ------------------- src/Graphics/Fountainhead/Parser.hs | 1244 ---------------------------- src/Graphics/Fountainhead/TrueType.hs | 1318 ------------------------------ src/Graphics/Fountainhead/Type.hs | 41 - 13 files changed, 3581 insertions(+), 3531 deletions(-) create mode 100644 lib/Graphics/Fountainhead.hs create mode 100644 lib/Graphics/Fountainhead/Compression.hs create mode 100644 lib/Graphics/Fountainhead/Dumper.hs create mode 100644 lib/Graphics/Fountainhead/Parser.hs create mode 100644 lib/Graphics/Fountainhead/TrueType.hs create mode 100644 lib/Graphics/Fountainhead/Type.hs delete mode 100644 src/Graphics/Fountainhead.hs delete mode 100644 src/Graphics/Fountainhead/Dumper.hs delete mode 100644 src/Graphics/Fountainhead/Parser.hs delete mode 100644 src/Graphics/Fountainhead/TrueType.hs delete mode 100644 src/Graphics/Fountainhead/Type.hs diff --git a/app/Main.hs b/app/Main.hs index afdee16..b79acaa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,36 +2,52 @@ module Main ( main ) where -import Data.Bifunctor (Bifunctor(..)) -import qualified Text.Megaparsec as Megaparsec import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.IO as Text.Lazy -import Graphics.Fountainhead (parseFontDirectoryFromFile) -import Graphics.Fountainhead.Dumper (DumpError(..), dumpTables) --- TODO: kern table since format 1. --- For details on subtable format see examples in TrueType reference. -import System.Environment (getArgs) +import Graphics.Fountainhead (dumpFontFile) import System.Exit (exitWith) import GHC.IO.Exception (ExitCode(..)) +import Options.Applicative + ( Parser + , ParserInfo(..) + , argument + , command + , execParser + , info + , fullDesc + , metavar + , progDesc + , str + , subparser + ) -fontMain :: FilePath -> IO () -fontMain fontFile = do - putStrLn ("Dumping File:" <> fontFile <> "\n\n") +data Operation + = Dump FilePath + | Afm FilePath + deriving (Eq, Show) - (processedState, initialResult) <- parseFontDirectoryFromFile fontFile +dump :: Parser Operation +dump = Dump + <$> argument str (metavar "FONTFILE") - case first DumpParseError initialResult >>= dumpTables processedState of - Right fontDump -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump - Left e - | DumpParseError bundle <- e -> putStr - $ Megaparsec.errorBundlePretty bundle - | DumpRequiredTableMissingError tableName <- e -> putStr - $ "Required table " <> tableName <> " is missing." +afm :: Parser Operation +afm = Afm + <$> argument str (metavar "FONTFILE") + +operationOptions :: ParserInfo Operation +operationOptions = info commands fullDesc + where + commands = subparser + $ command "dump" (info dump (progDesc "Dumping the contents of a TrueType Font file")) + <> command "afm" (info afm (progDesc "Generating Adobe Font Metrics files for TrueType fonts")) main :: IO () -main = do - programArguments <- getArgs - case programArguments of - [fontFile] -> fontMain fontFile - _ -> putStrLn "The program expects exactly one argument, the font file path." - >> exitWith (ExitFailure 2) +main = execParser operationOptions >>= handleArguments + where + handleArguments (Dump fontFile) + = putStrLn ("Dumping File:" <> fontFile <> "\n\n") + >> dumpFontFile fontFile + >>= either print (Text.Lazy.putStrLn . Text.Builder.toLazyText) + handleArguments (Afm _) + = putStrLn "The program expects exactly one argument, the font file path." + >> exitWith (ExitFailure 2) diff --git a/fountainhead.cabal b/fountainhead.cabal index 1271e18..c213d27 100644 --- a/fountainhead.cabal +++ b/fountainhead.cabal @@ -12,7 +12,7 @@ author: Eugen Wissner license-files: LICENSE license: MPL-2.0 -copyright: (c) 2023 Eugen Wissner +copyright: (c) 2024 Eugen Wissner category: Graphics extra-source-files: @@ -21,6 +21,7 @@ extra-source-files: common dependencies build-depends: + base >= 4.16 && < 5, bytestring ^>= 0.11.0, text ^>= 2.0, zlib ^>= 0.6.3 @@ -30,13 +31,13 @@ library import: dependencies exposed-modules: Graphics.Fountainhead + Graphics.Fountainhead.Compression Graphics.Fountainhead.Dumper Graphics.Fountainhead.Parser Graphics.Fountainhead.Type Graphics.Fountainhead.TrueType - hs-source-dirs: src + hs-source-dirs: lib build-depends: - base >= 4.16 && < 5, containers ^>= 0.6.5, megaparsec ^>= 9.3, time ^>= 1.12, @@ -53,13 +54,13 @@ executable fountainhead DuplicateRecordFields ExplicitForAll build-depends: - base, containers, + fountainhead, + megaparsec, + optparse-applicative ^>= 0.18.1, parser-combinators, vector, transformers, - time, - megaparsec, - fountainhead + time hs-source-dirs: app ghc-options: -Wall diff --git a/lib/Graphics/Fountainhead.hs b/lib/Graphics/Fountainhead.hs new file mode 100644 index 0000000..3852d51 --- /dev/null +++ b/lib/Graphics/Fountainhead.hs @@ -0,0 +1,49 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +-- | Convenience wrappers for working with font files. +module Graphics.Fountainhead + ( dumpFontFile + , parseFontDirectoryFromFile + ) where + +import Data.ByteString (ByteString) +import Data.Void (Void) +import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..)) +import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP) +import Graphics.Fountainhead.TrueType (FontDirectory(..)) +import qualified Text.Megaparsec as Megaparsec +import Text.Megaparsec (PosState(..), State(..)) +import System.IO (IOMode(..), withBinaryFile) +import Data.Bifunctor (Bifunctor(..)) +import qualified Data.Text.Lazy.Builder as Text.Builder +import Graphics.Fountainhead.Compression (hDecompress) + +parseFontDirectoryFromFile :: FilePath + -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory) +parseFontDirectoryFromFile fontFile = + withBinaryFile fontFile ReadMode withFontHandle + where + withFontHandle fontHandle = doParsing + <$> hDecompress fontHandle + doParsing ttfContents = + let initialState = Megaparsec.State + { stateInput = ttfContents + , stateOffset = 0 + , statePosState = Megaparsec.PosState + { pstateInput = ttfContents + , pstateOffset = 0 + , pstateSourcePos = Megaparsec.initialPos fontFile + , pstateTabWidth = Megaparsec.defaultTabWidth + , pstateLinePrefix = "" + } + , stateParseErrors = [] + } + in Megaparsec.runParser' fontDirectoryP initialState + +dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder) +dumpFontFile fontFile = do + (processedState, initialResult) <- parseFontDirectoryFromFile fontFile + + pure $ first DumpParseError initialResult >>= dumpTables processedState diff --git a/lib/Graphics/Fountainhead/Compression.hs b/lib/Graphics/Fountainhead/Compression.hs new file mode 100644 index 0000000..c1a05fc --- /dev/null +++ b/lib/Graphics/Fountainhead/Compression.hs @@ -0,0 +1,27 @@ +-- | Font compression and decompression. +module Graphics.Fountainhead.Compression + ( compress + , hDecompress + ) where + +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Codec.Compression.Zlib as Zlib +import System.IO (Handle, SeekMode(..), hFileSize, hSeek) + +-- | Reads the font from a file handle decompressing it if needed. +hDecompress :: Handle -> IO ByteString +hDecompress fontHandle = do + firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2 + hSeek fontHandle AbsoluteSeek 0 + fileSize <- fromIntegral <$> hFileSize fontHandle + case firstBytes of + 0x78 : [secondByte] + | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] -> + ByteString.Lazy.toStrict . Zlib.decompress + <$> ByteString.Lazy.hGet fontHandle fileSize + _ -> ByteString.hGetContents fontHandle + +compress :: ByteString -> ByteString +compress = ByteString.Lazy.toStrict . Zlib.compress . ByteString.Lazy.fromStrict diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs new file mode 100644 index 0000000..bbb17c2 --- /dev/null +++ b/lib/Graphics/Fountainhead/Dumper.hs @@ -0,0 +1,854 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +-- | Outputs information about a font as text. +module Graphics.Fountainhead.Dumper + ( DumpError(..) + , dumpCmap + , dumpGlyf + , dumpHead + , dumpHmtx + , dumpHhea + , dumpLoca + , dumpName + , dumpMaxp + , dumpOs2 + , dumpPost + , dumpTables + , dumpTrueType + , dumpOffsetTable + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import Data.Int (Int64, Int16) +import Data.Word (Word8, Word16, Word32) +import qualified Data.IntMap as IntMap +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Text.Lazy.Builder.Int as Text.Builder +import qualified Data.Text.Lazy.Builder.RealFloat as Text.Builder +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Void +import GHC.Records (HasField(..)) +import Graphics.Fountainhead.TrueType + ( CmapTable(..) + , CompoundGlyphDefinition(..) + , ComponentGlyphPartDescription(..) + , FontDirectory(..) + , FontDirectionHint(..) + , GASPRange(..) + , GASPTable(..) + , GlyphArgument(..) + , HeadTable(..) + , HheaTable(..) + , HmtxTable(..) + , OffsetSubtable(..) + , PostHeader(..) + , PostSubtable(..) + , PostFormat2Table(..) + , PostTable(..) + , TableDirectory(..) + , CmapEncoding(..) + , CmapSubtable(..) + , CmapFormat4Table(..) + , FontStyle(..) + , GlyphArgument(..) + , GlyphCoordinate(..) + , GlyphDefinition(..) + , GlyphDescription(..) + , GlyfTable(..) + , LongHorMetric(..) + , LocaTable(..) + , NameRecord (..) + , NameTable(..) + , IndexToLocFormat(..) + , OpenMaxpTable(..) + , MaxpTable(..) + , TrueMaxpTable(..) + , nameStringOffset + , Os2BaseFields(..) + , Os2MicrosoftFields(..) + , Os2Version1Fields(..) + , Os2Version4Fields(..) + , Os2Version5Fields(..) + , Os2Table(..) + , Panose(..) + , SimpleGlyphDefinition(..) + , CVTable(..) + , OutlineFlag(..) + , ComponentGlyphFlags(..) + , GlyphTransformationOption(..) + ) +import qualified Text.Megaparsec as Megaparsec +import Graphics.Fountainhead.Parser + ( fontDirectoryP + , parseTable + , cmapTableP + , headTableP + , hheaTableP + , hmtxTableP + , gaspTableP + , locaTableP + , maxpTableP + , nameTableP + , os2TableP + , postTableP + , cvTableP + , glyfTableP + ) +import Graphics.Fountainhead.Type + ( Fixed32(..) + , succIntegral + , ttfEpoch + , fixed2Double + ) +import Data.Foldable (Foldable(..), find) +import Data.Maybe (fromMaybe, catMaybes) +import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight) +import Data.Bits (Bits(..), (.>>.)) +import Data.Bifunctor (Bifunctor(first)) +import Data.List (intersperse) +import Prelude hiding (repeat) + +data DumpError + = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) + | DumpRequiredTableMissingError String + deriving Eq + +instance Show DumpError + where + show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle + show (DumpRequiredTableMissingError tableName) = + "Required table " <> tableName <> " is missing." + +data RequiredTables = RequiredTables + { hheaTable :: HheaTable + , headTable :: HeadTable + , locaTable :: LocaTable + } deriving (Eq, Show) + +paddedHexadecimal :: Integral a => a -> Text.Builder.Builder +paddedHexadecimal = ("0x" <>) + . Text.Builder.fromLazyText + . Text.Lazy.justifyRight 8 '0' + . Text.Builder.toLazyText + . Text.Builder.hexadecimal + +halfPaddedHexadecimal :: Integral a => a -> Text.Builder.Builder +halfPaddedHexadecimal = Text.Builder.fromLazyText + . Text.Lazy.justifyRight 4 '0' + . Text.Builder.toLazyText + . Text.Builder.hexadecimal + +justifyNumber :: Integral a => Int64 -> a -> Text.Builder.Builder +justifyNumber count = Text.Builder.fromLazyText + . Text.Lazy.justifyRight count ' ' + . Text.Builder.toLazyText + . Text.Builder.decimal + +newlineBuilder :: Text.Builder.Builder +newlineBuilder = Text.Builder.singleton '\n' + +dumpCaption :: String -> Text.Builder.Builder +dumpCaption headline = Text.Builder.fromString headline + <> newlineBuilder + <> Text.Builder.fromLazyText (Text.Lazy.replicate headlineLength "-") + <> newlineBuilder + where + headlineLength = fromIntegral $ Prelude.length headline + +dumpOffsetTable :: FontDirectory -> Text.Builder.Builder +dumpOffsetTable directory + = dumpCaption "Offset Table" + <> " sfnt version: 1.0\n number of tables: " + <> Text.Builder.decimal (numTables $ offsetSubtable directory) + <> newlineBuilder + <> dumpOffsetSummary (tableDirectory directory) + where + dumpOffsetSummary = mconcat . fmap dumpOffsetRow . zip [0 :: Int ..] + dumpOffsetRow (index, table) = justifyNumber 4 index + <> ". '" + <> Text.Builder.fromText (Text.decodeASCII $ tag table) + <> "' - checksum = " + <> paddedHexadecimal (getField @"checkSum" table) + <> ", offset = " + <> paddedHexadecimal (getField @"offset" table) + <> ", len = " + <> justifyNumber 9 (getField @"length" table) + <> newlineBuilder + +dumpFixed32 :: Fixed32 -> Text.Builder.Builder +dumpFixed32 (Fixed32 word) + = Text.Builder.decimal (shiftR word 16) + <> Text.Builder.singleton '.' + <> Text.Builder.decimal (word .&. 0xff00) + +dumpHmtx :: HmtxTable -> Text.Builder.Builder +dumpHmtx HmtxTable{..} = + let caption = dumpCaption "'hmtx' Table - Horizontal Metrics" + lastAccumulator = foldl' dumpHMetric (0 :: Int, caption) hMetrics + in snd $ foldl' dumpLeftSideBear lastAccumulator leftSideBearing + where + dumpLeftSideBear (index, accumulator) leftSideBearing' = + let withNewLine = dumpIndex index <> ". LSbear: " + <> justifyNumber 4 leftSideBearing' <> newlineBuilder + in (succ index, accumulator <> withNewLine) + dumpHMetric (index, accumulator) metric = + let LongHorMetric{ leftSideBearing = leftSideBearing', ..} = metric + withNewLine = dumpIndex index <> ". advWid: " + <> justifyNumber 4 advanceWidth <> ", LSBear: " + <> justifyNumber 4 leftSideBearing' <> newlineBuilder + in (succ index, accumulator <> withNewLine) + dumpIndex = justifyNumber 12 + +dumpHhea :: HheaTable -> Text.Builder.Builder +dumpHhea HheaTable{..} + = dumpCaption "'hhea' Table - Horizontal Header" + <> " 'hhea' version: " <> dumpFixed32 version <> newlineBuilder + <> " yAscender: " <> Text.Builder.decimal ascent <> newlineBuilder + <> " yDescender: " <> Text.Builder.decimal descent <> newlineBuilder + <> " yLineGap: " <> Text.Builder.decimal lineGap <> newlineBuilder + <> " advanceWidthMax: " <> Text.Builder.decimal advanceWidthMax <> newlineBuilder + <> " minLeftSideBearing: " <> Text.Builder.decimal minLeftSideBearing <> newlineBuilder + <> " minRightSideBearing: " <> Text.Builder.decimal minRightSideBearing <> newlineBuilder + <> " xMaxExtent: " <> Text.Builder.decimal xMaxExtent <> newlineBuilder + <> " caretSlopeRise: " <> Text.Builder.decimal caretSlopeRise <> newlineBuilder + <> " caretSlopeRun: " <> Text.Builder.decimal caretSlopeRun <> newlineBuilder + <> " reserved0: 0" <> newlineBuilder + <> " reserved1: 0" <> newlineBuilder + <> " reserved2: 0" <> newlineBuilder + <> " reserved3: 0" <> newlineBuilder + <> " reserved4: 0" <> newlineBuilder + <> " metricDataFormat: " <> Text.Builder.decimal metricDataFormat <> newlineBuilder + <> " numberOfHMetrics: " <> Text.Builder.decimal numOfLongHorMetrics <> newlineBuilder + +dumpHead :: HeadTable -> Text.Builder.Builder +dumpHead HeadTable{..} + = dumpCaption "'head' Table - Font Header" + <> " head version: " <> dumpFixed32 version <> newlineBuilder + <> " fontRevision: " <> dumpFixed32 fontRevision <> newlineBuilder + <> " checkSumAdjustment: " <> paddedHexadecimal checkSumAdjustment <> newlineBuilder + <> " magicNumber: " <> paddedHexadecimal magicNumber <> newlineBuilder + <> " flags: 0x" <> halfPaddedHexadecimal flags <> newlineBuilder + <> " unitsPerEm: " <> Text.Builder.decimal unitsPerEm <> newlineBuilder + <> " created: " <> "0x" <> longDateTime created <> newlineBuilder + <> " modified: " <> "0x" <> longDateTime modified <> newlineBuilder + <> " xMin: " <> Text.Builder.decimal xMin <> newlineBuilder + <> " yMin: " <> Text.Builder.decimal yMin <> newlineBuilder + <> " xMax: " <> Text.Builder.decimal xMax <> newlineBuilder + <> " yMax: " <> Text.Builder.decimal yMax <> newlineBuilder + <> " macStyle bits: " <> "0x" <> dumpFontStyle macStyle <> newlineBuilder + <> " lowestRecPPEM " <> Text.Builder.decimal lowestRecPPEM <> newlineBuilder + <> " fontDirectionHint " <> dumpFontDirectionHint fontDirectionHint <> newlineBuilder + <> " indexToLocFormat " <> dumpIndexToLocFormat indexToLocFormat <> newlineBuilder + <> " glyphDataFormat " <> Text.Builder.decimal glyphDataFormat <> newlineBuilder + +dumpIndexToLocFormat :: IndexToLocFormat -> Text.Builder.Builder +dumpIndexToLocFormat ShortOffsetIndexToLocFormat = "0" +dumpIndexToLocFormat LongOffsetIndexToLocFormat = "1" + +dumpFontDirectionHint :: FontDirectionHint -> Text.Builder.Builder +dumpFontDirectionHint = \case + MixedDirectionalGlyphs -> "0" + StronglyLeftToRightGlyphs -> "1" + LeftToRightGlyphsWithNeutrals -> "2" + StronglyRightToLeftGlyphs -> "-1" + RightToLeftGlyphsWithNeutrals -> "-2" + +dumpFontStyle :: FontStyle -> Text.Builder.Builder +dumpFontStyle FontStyle{..} = halfPaddedHexadecimal + $ foldr (go . fst) (zeroBits :: Int) + $ filter snd + $ zip [0..] [bold, italic, underline, outline, shadow, condensed, extended] + where + go bitNumber accumulator = setBit accumulator bitNumber + +longDateTime :: LocalTime -> Text.Builder.Builder +longDateTime localTime = Text.Builder.fromLazyText + $ Text.Lazy.justifyRight 16 '0' + $ Text.Builder.toLazyText + $ Text.Builder.hexadecimal + $ (truncate :: NominalDiffTime -> Int) + $ diffLocalTime localTime (LocalTime ttfEpoch midnight) + +dumpCVTable :: CVTable -> Text.Builder.Builder +dumpCVTable (CVTable cvTable) = dumpCaption "'cvt ' Table - Control Value Table" + <> "Size = " <> Text.Builder.decimal (tableSize * 2) + <> " bytes, " <> Text.Builder.decimal tableSize <> " entries\n" + <> foldMap (uncurry go) (zip [0..] cvTable) + where + tableSize = Prelude.length cvTable + go :: Int -> Int16 -> Text.Builder.Builder + go index' entry = justifyNumber 13 index' <> ". " + <> Text.Builder.decimal entry <> newlineBuilder + +dumpOs2 :: Os2Table -> Text.Builder.Builder +dumpOs2 = (dumpCaption "'OS/2' Table - OS/2 and Windows Metrics" <>) . go + where + go = \case + Os2Version0 baseFields msFields -> dumpBaseFields baseFields + <> maybe "" dumpMicrosoftFields msFields + Os2Version1 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion1Fields extraFields + Os2Version2 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields + Os2Version3 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields + Os2Version4 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion4Fields extraFields + Os2Version5 baseFields msFields extraFields -> dumpBaseFields baseFields + <> dumpMicrosoftFields msFields <> dumpVersion5Fields extraFields + dumpVersion1Fields Os2Version1Fields{..} + = " CodePage Range 1( Bits 0 - 31 ): " <> paddedHexadecimal ulCodePageRange1 <> newlineBuilder + <> " CodePage Range 2( Bits 32- 63 ): " <> paddedHexadecimal ulCodePageRange2 <> newlineBuilder + dumpVersion4Fields Os2Version4Fields{..} + = dumpVersion1Fields (Os2Version1Fields ulCodePageRange1 ulCodePageRange2) + <> " sxHeight: " <> Text.Builder.decimal sxHeight <> newlineBuilder + <> " sCapHeight: " <> Text.Builder.decimal sCapHeight <> newlineBuilder + <> " usDefaultChar: 0x" <> halfPaddedHexadecimal usDefaultChar <> newlineBuilder + <> " usBreakChar: 0x" <> halfPaddedHexadecimal usBreakChar <> newlineBuilder + <> " usMaxContext: " <> Text.Builder.decimal usMaxContext <> newlineBuilder + dumpVersion5Fields Os2Version5Fields{..} + = dumpVersion1Fields (Os2Version1Fields ulCodePageRange1 ulCodePageRange2) + <> " sxHeight: " <> Text.Builder.decimal sxHeight <> newlineBuilder + <> " sCapHeight: " <> Text.Builder.decimal sCapHeight <> newlineBuilder + <> " usDefaultChar: 0x" <> halfPaddedHexadecimal usDefaultChar <> newlineBuilder + <> " usBreakChar: 0x" <> halfPaddedHexadecimal usBreakChar <> newlineBuilder + <> " usMaxContext: " <> Text.Builder.decimal usMaxContext <> newlineBuilder + <> " usLowerOpticalPointSize: " + <> Text.Builder.decimal usLowerOpticalPointSize <> newlineBuilder + <> " usUpperOpticalPointSize: " + <> Text.Builder.decimal usUpperOpticalPointSize <> newlineBuilder + dumpMicrosoftFields Os2MicrosoftFields{..} + = " sTypoAscender: " <> Text.Builder.decimal sTypoAscender <> newlineBuilder + <> " sTypoDescender: " <> Text.Builder.decimal sTypoDescender <> newlineBuilder + <> " sTypoLineGap: " <> Text.Builder.decimal sTypoLineGap <> newlineBuilder + <> " usWinAscent: " <> Text.Builder.decimal usWinAscent <> newlineBuilder + <> " usWinDescent: " <> Text.Builder.decimal usWinDescent <> newlineBuilder + dumpBaseFields Os2BaseFields{..} + = " 'OS/2' version: " <> Text.Builder.decimal version <> newlineBuilder + <> " xAvgCharWidth: " <> Text.Builder.decimal xAvgCharWidth <> newlineBuilder + <> " usWeightClass: " <> weightClass usWeightClass <> newlineBuilder + <> " usWidthClass: " <> widthClass usWidthClass <> newlineBuilder + <> " fsType: " <> Text.Builder.decimal fsType <> newlineBuilder + <> " ySubscriptXSize: " <> Text.Builder.decimal ySubscriptXSize <> newlineBuilder + <> " ySubscriptYSize: " <> Text.Builder.decimal ySubscriptYSize <> newlineBuilder + <> " ySubscriptXOffset: " <> Text.Builder.decimal ySubscriptXOffset <> newlineBuilder + <> " ySubscriptYOffset: " <> Text.Builder.decimal ySubscriptYOffset <> newlineBuilder + <> " ySuperscriptXSize: " <> Text.Builder.decimal ySuperscriptXSize <> newlineBuilder + <> " ySuperscriptYSize: " <> Text.Builder.decimal ySuperscriptYSize <> newlineBuilder + <> " ySuperscriptXOffset: " <> Text.Builder.decimal ySuperscriptXOffset <> newlineBuilder + <> " ySuperscriptYOffset: " <> Text.Builder.decimal ySuperscriptYOffset <> newlineBuilder + <> " yStrikeoutSize: " <> Text.Builder.decimal yStrikeoutSize <> newlineBuilder + <> " yStrikeoutPosition: " <> Text.Builder.decimal yStrikeoutPosition <> newlineBuilder + <> " sFamilyClass:" <> familyClass sFamilyClass <> newlineBuilder + <> " PANOSE:" <> newlineBuilder <> dumpPanose panose + <> fold (Vector.imap dumpUnicodeRange ulUnicodeRange) + <> " achVendID: '" <> achVendID' achVendID <> "'\n" + <> " fsSelection: 0x" <> fsSelection' fsSelection <> newlineBuilder + <> " usFirstCharIndex: 0x" <> halfPaddedHexadecimal fsFirstCharIndex <> newlineBuilder + <> " usLastCharIndex: 0x" <> halfPaddedHexadecimal fsLastCharIndex <> newlineBuilder + fsSelection' value = + let description = fold + [ if testBit value 0 then "Italic " else "" + , if testBit value 5 then "Bold " else "" + ] + in halfPaddedHexadecimal value <> " '" <> description <> "'" + achVendID' = Text.Builder.fromText . Text.decodeLatin1 . ByteString.pack . fmap fromIntegral . toList + dumpUnicodeRange index value = + let bits = index * 32 + parens = "( Bits " <> Text.Builder.decimal bits <> " - " + <> Text.Builder.decimal (bits + 31) <> " ):" + in " Unicode Range: " <> Text.Builder.decimal (index + 1) + <> Text.Builder.fromLazyText (Text.Lazy.justifyLeft 25 ' ' (Text.Builder.toLazyText parens)) + <> paddedHexadecimal value + <> newlineBuilder + dumpPanose Panose{..} + = " Family Kind: " <> dumpPanoseField bFamilyType + <> " Serif Style: " <> dumpPanoseField bSerifStyle + <> " Weight: " <> dumpPanoseField bWeight + <> " Proportion: " <> dumpPanoseField bProportion + <> " Contrast: " <> dumpPanoseField bContrast + <> " Stroke: " <> dumpPanoseField bStrokeVariation + <> " Arm Style: " <> dumpPanoseField bArmStyle + <> " Lettreform: " <> dumpPanoseField bLetterform + <> " Midline: " <> dumpPanoseField bMidline + <> " X-height: " <> dumpPanoseField bXHeight + dumpPanoseField field' = + let numericField = Text.Builder.fromLazyText + $ Text.Lazy.justifyLeft 8 ' ' + $ Text.Builder.toLazyText + $ Text.Builder.decimal + $ fromEnum field' + in numericField + <> Text.Builder.singleton '\'' + <> Text.Builder.fromString (show field') + <> Text.Builder.singleton '\'' + <> newlineBuilder + familyClass value = + " " <> Text.Builder.decimal (value .>>. 8) <> " subclass = " <> Text.Builder.decimal (value .&. 0x00ff) + weightClass classValue + | Just wordValue <- fWeight classValue = Text.Builder.decimal classValue <> " '" <> wordValue <> "'" + | otherwise = Text.Builder.decimal classValue + widthClass classValue + | Just wordValue <- fWidth classValue = Text.Builder.decimal classValue <> " '" <> wordValue <> "'" + | otherwise = Text.Builder.decimal classValue + fWeight 100 = Just "Thin" + fWeight 200 = Just "Extra-light" + fWeight 300 = Just "Light" + fWeight 400 = Just "Normal" + fWeight 500 = Just "Medium" + fWeight 600 = Just "Semi-bold" + fWeight 700 = Just "Bold" + fWeight 800 = Just "Extra-bold" + fWeight 900 = Just "Black" + fWeight _ = Nothing + fWidth 1 = Just "Ultra-condensed" + fWidth 2 = Just "Extra-condensed" + fWidth 3 = Just "Condensed" + fWidth 4 = Just "Semi-condensed" + fWidth 5 = Just "Medium" + fWidth 6 = Just "Semi-expanded" + fWidth 7 = Just "Expanded" + fWidth 8 = Just "Extra-expanded" + fWidth 9 = Just "Ultra-expanded" + fWidth _ = Nothing + +dumpPost :: PostTable -> Text.Builder.Builder +dumpPost PostTable{ postHeader = PostHeader{..}, postSubtable } + = dumpCaption "'post' Table - PostScript" <> newlineBuilder + <> " 'post' format: " <> dumpFixed32 format <> newlineBuilder + <> " italicAngle: " <> dumpFixed32 format <> newlineBuilder + <> " underlinePosition: " <> Text.Builder.decimal underlinePosition <> newlineBuilder + <> " underlineThichness: " <> Text.Builder.decimal underlineThickness <> newlineBuilder + <> " isFixedPitch: " <> dNumber isFixedPitch <> newlineBuilder + <> " minMemType42: " <> dNumber minMemType42 <> newlineBuilder + <> " maxMemType42: " <> dNumber maxMemType42 <> newlineBuilder + <> " minMemType1: " <> dNumber minMemType1 <> newlineBuilder + <> " maxMemType1: " <> dNumber maxMemType1 <> newlineBuilder + <> dumpPostSubtable + where + dNumber = (<> Text.Builder.singleton 'd') . Text.Builder.decimal + dumpPostSubtable = case postSubtable of + None -> "" -- Format 1 and 3 do not require a subtable. + PostFormat2 PostFormat2Table{..} + -> " Format 2.0: Non-Standard (for PostScript) TrueType Glyph Set." <> newlineBuilder + <> " numGlyphs: " <> Text.Builder.decimal (Prelude.length glyphNameIndex) + <> newlineBuilder <> fold (Vector.imap (dumpFormat2Pair names) glyphNameIndex) + PostFormat25 _ -> "Format 2.5" + PostFormat4 _ -> "Format 4.0" + dumpFormat2Pair names index glyphNameIndex' + = " Glyf " <> justifyNumber 3 index + <> " -> " <> glyphType names glyphNameIndex' + <> newlineBuilder + glyphType names glyphNameIndex' + | glyphNameIndex' >= 0 + , glyphNameIndex' <= 257 = "Mac Glyph # " <> justifyNumber 3 glyphNameIndex' + | glyphNameIndex' >= 258 + , glyphNameIndex' <= 32767 = + let nameIndex = fromIntegral $ glyphNameIndex' - 258 + in "PSGlyph Name # " <> justifyNumber 3 (succ nameIndex) <> ", '" + <> Text.Builder.fromText (Text.decodeASCII (names Vector.! nameIndex)) + <> Text.Builder.singleton '\'' + | otherwise = "Reserved" + +dumpCmap :: CmapTable -> Text.Builder.Builder +dumpCmap CmapTable{..} + = dumpCaption "'cmap' Table - Character to Glyph Index Mapping Table" + <> " 'cmap' version: " <> Text.Builder.decimal version <> newlineBuilder + <> " number of encodings: " <> Text.Builder.decimal encodingsLength <> newlineBuilder + <> " number of subtables: " <> Text.Builder.decimal (Prelude.length subtables) <> newlineBuilder + <> newlineBuilder + <> snd (foldr dumpCmapEncoding (pred encodingsLength, "") encodings) <> newlineBuilder + <> snd (foldr dumpCmapSubTable (pred subTablesLength, "") subtables) <> newlineBuilder + where + encodingsLength = Prelude.length encodings + subTablesLength = IntMap.size subtables + dumpCmapEncoding CmapEncoding{..} (index, accumulator) = + let findSubTableIndex = Text.Builder.decimal + . Prelude.length + . filter ((< offset) . fromIntegral) + . IntMap.keys + summary = "Encoding " <> Text.Builder.decimal index + <> ". PlatformID: " <> Text.Builder.decimal platformID <> newlineBuilder + <> " EcodingID: " <> Text.Builder.decimal platformSpecificID <> newlineBuilder + <> " SubTable: " <> findSubTableIndex subtables + <> ", Offset: " <> paddedHexadecimal offset <> newlineBuilder + in (pred index, summary <> newlineBuilder <> accumulator) + dumpCmapSubTable currentSubTable (index, accumulator) = + let contents = "SubTable " <> Text.Builder.decimal index + <> ". " <> dumpCmapSubTableFormat currentSubTable + in (pred index, contents <> accumulator) + dumpCmapSubTableFormat = \case + (CmapFormat0 _) -> "Format 0" + (CmapFormat2 _) -> "Format 2" + (CmapFormat4 CmapFormat4Table{..}) -> + let segCount = Vector.length startCode + dumpSegment' = dumpSegment segCount glyphIndexArray + in "Format 4 - Segment mapping to delta values\n\ + \ Length: 994\n\ + \ Version: 0\n\ + \ segCount: " + <> Text.Builder.decimal segCount + <> newlineBuilder <> " searchRange: " + <> Text.Builder.decimal searchRange + <> newlineBuilder <> " entrySelector: " + <> Text.Builder.decimal entrySelector + <> newlineBuilder <> " rangeShift: " + <> Text.Builder.decimal (segCount * 2 - fromIntegral searchRange) + <> newlineBuilder + <> fold (Vector.izipWith4 (dumpSegmentSummary segCount) startCode endCode idDelta idRangeOffset) + <> " Number of glyphIndex " + <> Text.Builder.decimal (Vector.length glyphIndexArray) <> newlineBuilder + <> fold (Vector.imap dumpGlyphAtIndex glyphIndexArray) + <> fold (Vector.izipWith4 dumpSegment' startCode endCode idDelta idRangeOffset) + (CmapFormat6 _) -> "Format 6" + (CmapFormat8 _) -> "Format 8" + (CmapFormat10 _) -> "Format 10" + (CmapFormat12 _) -> "Format 12" + (CmapFormat13 _) -> "Format 13" + (CmapFormat14 _) -> "Format 14" + dumpSegment :: Int -> Vector Word16 -> Int -> Word16 -> Word16 -> Word16 -> Word16 -> Text.Builder.Builder + dumpSegment segCount glyphIndexArray' segmentIndex startCode' endCode' idDelta' idRangeOffset' = + let charRange = [startCode'..endCode'] + dumpSegmentCharIndex' = + dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode' + in "Segment " <> Text.Builder.decimal segmentIndex <> ":\n" + <> foldMap dumpSegmentCharIndex' charRange + dumpSegmentCharIndex segCount glyphIndexArray' segmentIndex idDelta' idRangeOffset' startCode' charCode = + let calculateGlyphIndex' = + calculateGlyphIndex charCode segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode' + in " Char 0x" + <> halfPaddedHexadecimal charCode <> " -> Index " + <> Text.Builder.decimal calculateGlyphIndex' + <> newlineBuilder + dumpSegmentSummary segCount index startCode' endCode' idDelta' idRangeOffset' + = " Seg " <> justifyNumber 5 index + <> " : St = " <> halfPaddedHexadecimal startCode' + <> ", En = " <> halfPaddedHexadecimal endCode' + <> ", D = " <> justifyNumber 6 idDelta' + <> ", RO = " <> justifyNumber 6 idRangeOffset' + <> ", gId# = " <> dumpGlyphId index segCount idRangeOffset' + <> newlineBuilder + dumpGlyphId segmentIndex segCount idRangeOffset' + = maybe "N/A" Text.Builder.decimal + $ calculateGlyphId segmentIndex segCount idRangeOffset' + calculateGlyphIndex :: Word16 -> Int -> Int -> Vector Word16 -> Word16 -> Word16 -> Word16 -> Int + calculateGlyphIndex c segmentIndex segCount glyphIndexArray' idRangeOffset' idDelta' startCode' = + let defaultIndex = fromIntegral $ c + idDelta' + addOffset = fromIntegral + . fromMaybe 0 + . (glyphIndexArray' Vector.!?) + . (+ fromIntegral (c - startCode')) + in maybe defaultIndex addOffset + $ calculateGlyphId segmentIndex segCount idRangeOffset' + calculateGlyphId segmentIndex segCount idRangeOffset' + | idRangeOffset' == 0 = Nothing + | otherwise = Just $ segmentIndex - segCount + (fromIntegral idRangeOffset' `div` 2) + dumpGlyphAtIndex index element = " glyphIdArray[" <> Text.Builder.decimal index <> "] = " + <> Text.Builder.decimal element <> newlineBuilder + +dumpLoca :: LocaTable -> Text.Builder.Builder +dumpLoca table = + dumpCaption "'loca' Table - Index to Location" + <> go table + where + go (LongLocaTable elements) = dumpElements elements + go (ShortLocaTable elements) = dumpElements + $ (* 2) + . (fromIntegral :: Word16 -> Word32) + <$> elements + dumpElements elements = + case Vector.unsnoc elements of + Just (init', last') + -> foldMap dumpLocaLine (Vector.indexed init') + <> " Ended at " <> paddedHexadecimal last' <> newlineBuilder + Nothing -> mempty + dumpLocaLine :: Integral a => (Int, a) -> Text.Builder.Builder + dumpLocaLine (index, element) + = " Idx " <> justifyNumber 6 index + <> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder + +dumpName :: NameTable -> Text.Builder.Builder +dumpName table'@NameTable{..} = dumpCaption "'name' Table - Naming Table" + <> " Format: " <> Text.Builder.decimal format <> newlineBuilder + <> " Number of Record: " <> Text.Builder.decimal (Prelude.length nameRecord) <> newlineBuilder + <> " Storage offset: " <> Text.Builder.decimal (nameStringOffset table') <> newlineBuilder + <> foldMap go (zip3 [0 :: Int ..] nameRecord variable) + where + go (index, NameRecord{ length = length', ..}, variable') + = "Name table " <> justifyNumber 3 index <> "." + <> " PlatformID: " <> Text.Builder.decimal platformID <> newlineBuilder + <> " EncodingID: " <> Text.Builder.decimal platformSpecificID <> newlineBuilder + <> " LanguageID: " <> Text.Builder.decimal languageID <> newlineBuilder + <> " NameID: " <> Text.Builder.decimal nameID <> newlineBuilder + <> " Length: " <> Text.Builder.decimal length' <> newlineBuilder + <> " Offset: " <> Text.Builder.decimal offset <> newlineBuilder + <> foldMap (" " <>) (dumpHexString $ ByteString.unpack variable') + +dumpHexString :: [Word8] -> [Text.Builder.Builder] +dumpHexString byteCodes + | null byteCodes = [dumpHexLine " > " byteCodes] + | Prelude.length byteCodes < 10 = [dumpHexLine " > " byteCodes] + | otherwise = dumpHexLine " > " byteCodes + : dumpHexString (drop 10 byteCodes) + where + dumpHexLine separator variable' = + let firstTen = take 10 variable' + digits = fold $ intersperse (Text.Builder.singleton ' ') $ hexByte <$> firstTen + printables = foldMap printableByte firstTen + in digits + <> Text.Builder.fromText (Text.replicate (10 - Prelude.length firstTen) " ") + <> separator + <> printables + <> newlineBuilder + printableByte :: Word8 -> Text.Builder.Builder + printableByte code + | code >= 0x20 + , code < 0x7f = Text.Builder.singleton $ toEnum $ fromIntegral code + | otherwise = Text.Builder.singleton '.' + +hexByte :: Integral a => a -> Text.Builder.Builder +hexByte = Text.Builder.fromLazyText + . Text.Lazy.justifyRight 2 '0' + . Text.Builder.toLazyText + . Text.Builder.hexadecimal + +dumpMaxp :: MaxpTable -> Text.Builder.Builder +dumpMaxp (TrueMaxp TrueMaxpTable{..}) + = dumpCaption "'maxp' Table - Maximum Profile" + <> " 'maxp' version: " <> dumpFixed32 version <> newlineBuilder + <> " numGlyphs: " <> Text.Builder.decimal numGlyphs <> newlineBuilder + <> " maxPoints: " <> Text.Builder.decimal maxPoints <> newlineBuilder + <> " maxContours: " <> Text.Builder.decimal maxContours <> newlineBuilder + <> " maxCompositePoints: " <> Text.Builder.decimal maxComponentPoints <> newlineBuilder + <> " maxCompositeContours: " <> Text.Builder.decimal maxComponentContours <> newlineBuilder + <> " maxZones: " <> Text.Builder.decimal maxZones <> newlineBuilder + <> " maxTwilightPoints: " <> Text.Builder.decimal maxTwilightPoints <> newlineBuilder + <> " maxStorage: " <> Text.Builder.decimal maxStorage <> newlineBuilder + <> " maxFunctionDefs: " <> Text.Builder.decimal maxFunctionDefs <> newlineBuilder + <> " maxInstructionDefs: " <> Text.Builder.decimal maxInstructionDefs <> newlineBuilder + <> " maxStackElements: " <> Text.Builder.decimal maxStackElements <> newlineBuilder + <> " maxSizeOfInstructions: " <> Text.Builder.decimal maxSizeOfInstructions <> newlineBuilder + <> " maxComponentElements: " <> Text.Builder.decimal maxComponentElements <> newlineBuilder + <> " maxCompoenetDepth: " <> Text.Builder.decimal maxComponentDepth <> newlineBuilder +dumpMaxp (OpenMaxp OpenMaxpTable{..}) + = dumpCaption "'maxp' Table - Maximum Profile" + <> " 'maxp' version: " <> dumpFixed32 version <> newlineBuilder <> newlineBuilder + <> " numGlyphs: " <> Text.Builder.decimal numGlyphs <> newlineBuilder + +dumpGASP :: GASPTable -> Text.Builder.Builder +dumpGASP GASPTable{..} = dumpCaption "'gasp' Table - Grid-fitting And Scan-conversion Procedure" + <> "'gasp' version: " <> Text.Builder.decimal version <> newlineBuilder + <> "numRanges: " <> Text.Builder.decimal (Prelude.length gaspRange) <> newlineBuilder + <> foldMap dumpGASPRange (zip [0..] gaspRange) + where + dumpGASPRange :: (Int, GASPRange) -> Text.Builder.Builder + dumpGASPRange (index', GASPRange{..}) = newlineBuilder + <> " gasp Range " <> Text.Builder.decimal index' <> newlineBuilder + <> " rangeMaxPPEM: " <> Text.Builder.decimal rangeMaxPPEM <> newlineBuilder + <> " rangeGaspBehavior: 0x" <> halfPaddedHexadecimal rangeGaspBehavior <> newlineBuilder + +dumpGlyf :: GlyfTable -> Text.Builder.Builder +dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data" + <> foldMap go (Vector.indexed glyfDescriptions) + where + go (glyphIndex, GlyphDescription{..}) + = "Glyph " <> justifyNumber 6 glyphIndex <> Text.Builder.singleton '.' <> newlineBuilder + <> " numberOfContours: " <> Text.Builder.decimal numberOfContours <> newlineBuilder + <> " xMin: " <> Text.Builder.decimal xMin <> newlineBuilder + <> " yMin: " <> Text.Builder.decimal yMin <> newlineBuilder + <> " xMax: " <> Text.Builder.decimal xMax <> newlineBuilder + <> " yMax: " <> Text.Builder.decimal yMax <> newlineBuilder + <> newlineBuilder <> dumpGlyphDefinition definition <> newlineBuilder + dumpEndPoint (endPointIndex, endPoint) + = " " <> justifyNumber 2 endPointIndex + <> ": " <> Text.Builder.decimal endPoint <> newlineBuilder + dumpGlyphDefinition (SimpleGlyph SimpleGlyphDefinition{..}) + = " EndPoints" <> newlineBuilder + <> " ---------" <> newlineBuilder + <> foldMap dumpEndPoint (Vector.indexed endPtsOfContours) <> newlineBuilder + <> " Length of Instructions: " + <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder + <> newlineBuilder <> " Flags" <> newlineBuilder + <> " -----" <> newlineBuilder + <> fst (Vector.foldl' foldFlag ("", 0) flags) <> newlineBuilder + <> " Coordinates" <> newlineBuilder + <> " -----------" <> newlineBuilder + <> fst (Vector.ifoldl' foldCoordinate mempty coordinates) + dumpGlyphDefinition (CompoundGlyph CompoundGlyphDefinition{..}) + = foldMap (dumpCompoundGlyph $ Vector.length components) (Vector.indexed components) + <> newlineBuilder <> " Length of Instructions: " + <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder + dumpCompoundGlyph :: Int -> (Int, ComponentGlyphPartDescription) -> Text.Builder.Builder + dumpCompoundGlyph componentsLength (componentIndex, description) = + let moreComponents = succ componentIndex < componentsLength + compoundFlags = dumpCompoundFlags moreComponents description + ComponentGlyphPartDescription{..} = description + in " " <> Text.Builder.decimal componentIndex + <> ": Flags: 0x" <> compoundFlags <> newlineBuilder + <> " Glyf Index: " <> Text.Builder.decimal glyphIndex <> newlineBuilder + <> " X" <> dumpArgument argument1 <> newlineBuilder + <> " Y" <> dumpArgument argument2 <> newlineBuilder + <> dumpTransformationOption transformationOption + <> " Others: " <> dumpOtherFlags flags <> newlineBuilder + <> newlineBuilder -- TODO + dumpTransformationOption GlyphNoScale = "" + dumpTransformationOption (GlyphScale scale) = + " X,Y Scale: " <> Text.Builder.realFloat (fixed2Double scale) <> newlineBuilder + dumpTransformationOption (GlyphXyScale xScale yScale) + = " X Scale: " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder + <> " Y Scale: " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder + dumpTransformationOption (Glyph2By2Scale xScale scale01 scale10 yScale) + = " X Scale: " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder + <> " X,Y Scale: " <> Text.Builder.realFloat (fixed2Double scale01) <> newlineBuilder + <> " Y,X Scale: " <> Text.Builder.realFloat (fixed2Double scale10) <> newlineBuilder + <> " Y Scale: " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder + dumpOtherFlags ComponentGlyphFlags{..} = + let roundXyToGridText = if roundXyToGrid then "Round X,Y to Grid " else " " + useMyMetricsText = if useMyMetrics then "Use My Metrics " else " " + overlapCompoundText = if overlapCompound then "Overlap " else " " + in roundXyToGridText <> overlapCompoundText <> useMyMetricsText + dumpCompoundFlags :: Bool -> ComponentGlyphPartDescription -> Text.Builder.Builder + dumpCompoundFlags moreComponents ComponentGlyphPartDescription{..} = + let setBits = glyphArgumentBits argument1 + <> componentFlagBits flags + <> transformationOptionBits transformationOption + setBits' = if moreComponents then 5 : setBits else setBits + in Text.Builder.hexadecimal + $ foldr (flip setBit) (zeroBits :: Word16) setBits' + dumpArgument (GlyphInt8Argument argument) = + " BOffset: " <> Text.Builder.decimal argument + dumpArgument (GlyphInt16Argument argument) = + " WOffset: " <> Text.Builder.decimal argument + dumpArgument (GlyphWord8Argument argument) = + " BPoint: " <> Text.Builder.decimal argument + dumpArgument (GlyphWord16Argument argument) = + " WPoint: " <> Text.Builder.decimal argument + glyphArgumentBits (GlyphInt16Argument _) = [0, 1] + glyphArgumentBits (GlyphWord16Argument _) = [0] + glyphArgumentBits (GlyphInt8Argument _) = [1] + glyphArgumentBits (GlyphWord8Argument _) = [] + componentFlagBits ComponentGlyphFlags{..} = catMaybes + [ if roundXyToGrid then Just 2 else Nothing + , if weHaveInstructions then Just 8 else Nothing + , if useMyMetrics then Just 9 else Nothing + , if overlapCompound then Just 10 else Nothing + ] + transformationOptionBits GlyphScale{} = [3] + transformationOptionBits GlyphXyScale{} = [6] + transformationOptionBits Glyph2By2Scale{} = [7] + transformationOptionBits GlyphNoScale = [] + dumpFlag lineValue coordinateIndex + = " " <> justifyNumber 2 coordinateIndex <> lineValue + foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int) + foldFlag (accumulator, coordinateIndex) OutlineFlag{..} = + let lineValue = ": " + <> (if thisYIsSame then "YDual " else " ") + <> (if thisXIsSame then "XDual " else " ") + <> (if repeat > 0 then "Repeat " else " ") + <> (if yShortVector then "Y-Short " else " ") + <> (if xShortVector then "X-Short " else " ") + <> (if onCurve then "On" else "Off") + <> newlineBuilder + repeatN = succIntegral repeat + repeatedLines = fold + $ Vector.cons accumulator + $ dumpFlag lineValue + <$> Vector.enumFromN coordinateIndex repeatN + in (repeatedLines, coordinateIndex + repeatN) + foldCoordinate + :: (Text.Builder.Builder, GlyphCoordinate) + -> Int + -> GlyphCoordinate + -> (Text.Builder.Builder, GlyphCoordinate) + foldCoordinate (accumulator, absCoordinate) coordinateIndex relCoordinate = + let nextAbs = relCoordinate <> absCoordinate + newLine = " " <> justifyNumber 2 coordinateIndex + <> " Rel " <> dumpCoordinate relCoordinate + <> " -> Abs " <> dumpCoordinate nextAbs + <> newlineBuilder + in (accumulator <> newLine, nextAbs) + dumpCoordinate GlyphCoordinate{..} + = "(" <> justifyNumber 7 coordinateX <> ", " + <> justifyNumber 7 coordinateY <> ")" + +dumpTables + :: Megaparsec.State ByteString Void + -> FontDirectory + -> Either DumpError Text.Builder.Builder +dumpTables processedState directory@FontDirectory{..} + = parseRequired >>= traverseDirectory + where + traverseDirectory parsedRequired = + let initial = Right $ dumpOffsetTable directory + in foldl' (go parsedRequired) initial tableDirectory + parseRequired = do + requiredHhea <- findRequired "hhea" hheaTableP + requiredHead@HeadTable{ indexToLocFormat } <- + findRequired "head" headTableP + requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat) + pure $ RequiredTables + { hheaTable = requiredHhea + , headTable = requiredHead + , locaTable = requiredLoca + } + findRequired tableName parser = + let missingError = Left $ DumpRequiredTableMissingError tableName + parseFound tableEntry = parseTable tableEntry parser processedState + in maybe missingError (first DumpParseError . parseFound) + $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory + go _ (Left accumulator) _ = Left accumulator + go parsedRequired (Right accumulator) tableEntry + = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) + $ dumpSubTable parsedRequired tableEntry + concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) + <$> builderDump + dumpSubTable RequiredTables{..} tableEntry = + case getField @"tag" tableEntry of + "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState + "head" -> Just $ Right $ dumpHead headTable + "hhea" -> Just $ Right $ dumpHhea hheaTable + "hmtx" -> Just $ dumpHmtx + <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState + "loca" -> Just $ Right $ dumpLoca locaTable + "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState + "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState + "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState + "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState + "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState + "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState + "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState + _ -> Nothing + +dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder +dumpTrueType ttfContents fontFile = + let initialState = Megaparsec.State + { stateInput = ttfContents + , stateOffset = 0 + , statePosState = Megaparsec.PosState + { pstateInput = ttfContents + , pstateOffset = 0 + , pstateSourcePos = Megaparsec.initialPos fontFile + , pstateTabWidth = Megaparsec.defaultTabWidth + , pstateLinePrefix = "" + } + , stateParseErrors = [] + } + (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState + + in first DumpParseError initialResult >>= dumpTables processedState diff --git a/lib/Graphics/Fountainhead/Parser.hs b/lib/Graphics/Fountainhead/Parser.hs new file mode 100644 index 0000000..31dcd0e --- /dev/null +++ b/lib/Graphics/Fountainhead/Parser.hs @@ -0,0 +1,1244 @@ +{- 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/lib/Graphics/Fountainhead/TrueType.hs b/lib/Graphics/Fountainhead/TrueType.hs new file mode 100644 index 0000000..0c15081 --- /dev/null +++ b/lib/Graphics/Fountainhead/TrueType.hs @@ -0,0 +1,1318 @@ +{- 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/lib/Graphics/Fountainhead/Type.hs b/lib/Graphics/Fountainhead/Type.hs new file mode 100644 index 0000000..e809d9c --- /dev/null +++ b/lib/Graphics/Fountainhead/Type.hs @@ -0,0 +1,41 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +-- | Generic font types. +module Graphics.Fountainhead.Type + ( F2Dot14(..) + , Fixed32(..) + , FWord + , UFWord + , fixed2Double + , succIntegral + , ttfEpoch + ) where + +import Data.Bits ((.>>.), (.&.)) +import Data.Int (Int16) +import Data.Word (Word16, Word32) +import Data.Time (Day(..)) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) + +newtype Fixed32 = Fixed32 Word32 + deriving (Eq, Show) + +newtype F2Dot14 = F2Dot14 Int16 + deriving (Eq, Show) + +type FWord = Int16 +type UFWord = Word16 + +ttfEpoch :: Day +ttfEpoch = fromOrdinalDate 1904 1 + +succIntegral :: Integral a => a -> Int +succIntegral = succ . fromIntegral + +fixed2Double :: F2Dot14 -> Double +fixed2Double (F2Dot14 fixed) = + let mantissa = realToFrac (fixed .>>. 14) + fraction = realToFrac (fixed .&. 0x3fff) / 16384.0 + in mantissa + fraction 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 -- cgit v1.2.3