diff options
Diffstat (limited to 'src/Graphics/Fountainhead/Parser.hs')
| -rw-r--r-- | src/Graphics/Fountainhead/Parser.hs | 1244 |
1 files changed, 0 insertions, 1244 deletions
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 |