fountainhead/src/Graphics/Fountainhead/Parser.hs

1203 lines
42 KiB
Haskell
Raw Normal View History

2023-11-10 11:57:08 +01:00
{- 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/. -}
2023-03-13 10:51:25 +01:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeApplications #-}
-- | Font parser.
module Graphics.Fountainhead.Parser
( cmapTableP
, cvTableP
, f2Dot14P
, fixedP
, fontDirectoryP
, fpgmTableP
, glyfTableP
, hdmxTableP
, headTableP
, hheaTableP
, hmtxTableP
, longDateTimeP
, longLocaTableP
, maxpTableP
, nameTableP
, os2TableP
, panoseP
, parseTable
, pascalStringP
, postTableP
, prepTableP
, shortLocaTableP
, word24P
) where
import Control.Applicative (Alternative(..))
import Control.Monad (foldM)
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 (nub, sort, sortOn, nubBy, sortBy)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Time
( LocalTime(..)
, TimeOfDay(..)
, addDays
, secondsToDiffTime
, timeToTimeOfDay
)
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
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(..)
, GlyfTable(..)
, GlyphArgument(..)
, GlyphCoordinate(..)
, GlyphDefinition(..)
, GlyphDescription(..)
, GlyphTransformationOption(..)
, HdmxTable(..)
, DeviceRecord(..)
, HeadTable(..)
, HheaTable(..)
, HmtxTable(..)
, 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(..))
import Text.Megaparsec ((<?>))
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary
type Parser = Megaparsec.Parsec Void ByteString
-- * 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 } =
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.word16be
<*> 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.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
<*> Megaparsec.Binary.word16be
<*> Megaparsec.Binary.word16be
<* Megaparsec.eof
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"
-- * Horizontal metrics table
longHorMetricP :: Parser LongHorMetric
longHorMetricP = LongHorMetric
<$> Megaparsec.Binary.word16be
<*> Megaparsec.Binary.int16be
hmtxTableP :: Int -> Parser HmtxTable
hmtxTableP numOfLongHorMetrics = HmtxTable
<$> countP 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
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
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
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 (coordinateP xFlagPair) mempty flags'
ys <- Vector.foldM (coordinateP yFlagPair) mempty flags'
pure $ SimpleGlyphDefinition
{ endPtsOfContours = endPtsOfContours'
, instructions = instructions'
, coordinates = mkCoordinate <$> Vector.zip3 xs ys flags'
}
where
mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve
xFlagPair :: OutlineFlag -> (Bool, Bool)
xFlagPair OutlineFlag{ xShortVector, thisXIsSame } =
(xShortVector, thisXIsSame)
yFlagPair :: OutlineFlag -> (Bool, Bool)
yFlagPair OutlineFlag{ yShortVector, thisYIsSame } =
(yShortVector, thisYIsSame)
coordinateP
:: (OutlineFlag -> (Bool, Bool))
-> Vector Int16
-> OutlineFlag
-> Parser (Vector Int16)
coordinateP get accumulator first =
case get first of
(True, True) -> Vector.snoc accumulator . fromIntegral
<$> Megaparsec.Binary.word8
<?> "1 byte long positive coordinate"
(True, False)
-> Vector.snoc accumulator . negate . fromIntegral
<$> Megaparsec.Binary.word8
<?> "1 byte long negative coordinate"
(False, False) -> Vector.snoc accumulator
<$> Megaparsec.Binary.int16be
<?> "2 bytes long coordinate"
(False, True) -> pure $ Vector.snoc accumulator 0
flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag)
flagsP remaining accumulator
| remaining < 0 = pure accumulator
| otherwise = do
flag <- Megaparsec.Binary.word8 <?> "outline flags"
let flag' = OutlineFlag
{ onCurve = testBit flag 0
, xShortVector = testBit flag 1
, yShortVector = testBit flag 2
, thisXIsSame = testBit flag 4
, thisYIsSame = testBit flag 5
}
repeat = testBit flag 3
repeatN <-
if repeat
then (1 +)
. fromIntegral
<$> Megaparsec.Binary.word8
<?> "flag repeat count"
else pure 1
flagsP (remaining - repeatN)
$ accumulator <> Vector.replicate repeatN 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
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
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
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
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
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
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
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
rangeShift' <- Megaparsec.Binary.word16be
-- 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 = succ $ fromIntegral $ 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)
epoch = fromOrdinalDate 1904 1
in LocalTime
{ localDay = addDays (fromIntegral totalDays) epoch
, localTimeOfDay = timeToTimeOfDay
$ secondsToDiffTime
$ fromIntegral secondsOfDay
}
fixedP :: Parser Fixed32
fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be
parseTable
:: TableDirectory
-> Parser a
-> Megaparsec.State ByteString Void
-> Either (Megaparsec.ParseErrorBundle ByteString Void) a
parseTable TableDirectory{ offset, 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 $> AnyStrokeVariatoon)
<|> (Megaparsec.single 1 $> NoFitStrokeVariatoon)
<|> (Megaparsec.single 2 $> GradualDiagonalStrokeVariatoon)
<|> (Megaparsec.single 3 $> GradualTransitionalStrokeVariatoon)
<|> (Megaparsec.single 4 $> GradualVerticalStrokeVariatoon)
<|> (Megaparsec.single 5 $> GradualHorizontalStrokeVariatoon)
<|> (Megaparsec.single 6 $> RapidVerticalStrokeVariatoon)
<|> (Megaparsec.single 7 $> RapidHorizontalStrokeVariatoon)
<|> (Megaparsec.single 8 $> InstantVerticalStrokeVariatoon)
<?> "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"