1247 lines
43 KiB
Haskell
1247 lines
43 KiB
Haskell
{- 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
|
|
, ParseState
|
|
, 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
|
|
type ParseState = Megaparsec.State 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
|
|
-> ParseState
|
|
-> 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
|