diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs index 91659ee..647f159 100644 --- a/src/Graphics/Fountainhead/Dumper.hs +++ b/src/Graphics/Fountainhead/Dumper.hs @@ -3,7 +3,6 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} @@ -15,6 +14,8 @@ module Graphics.Fountainhead.Dumper , dumpCmap , dumpHead , dumpHmtx + , dumpHhea + , dumpLoca , dumpTrueType , dumpOffsetTable ) where @@ -22,7 +23,7 @@ module Graphics.Fountainhead.Dumper import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Char8 import Data.Int (Int64) -import Data.Word (Word16) +import Data.Word (Word16, Word32) import qualified Data.IntMap as IntMap import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as Text.Lazy @@ -46,6 +47,8 @@ import Graphics.Fountainhead.TrueType , CmapFormat4Table(..) , FontStyle(..) , LongHorMetric(..) + , LocaTable(..) + , IndexToLocFormat(..) ) import qualified Text.Megaparsec as Megaparsec import Graphics.Fountainhead.Parser @@ -55,6 +58,7 @@ import Graphics.Fountainhead.Parser , headTableP , hheaTableP , hmtxTableP + , locaTableP ) import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch) import Data.Foldable (Foldable(..), find) @@ -67,6 +71,11 @@ data DumpError = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) | DumpRequiredTableMissingError String +data RequiredTables = RequiredTables + { hheaTable :: HheaTable + , headTable :: HeadTable + } deriving (Eq, Show) + paddedHexadecimal :: Integral a => a -> Text.Builder.Builder paddedHexadecimal = ("0x" <>) . Text.Builder.fromLazyText @@ -180,9 +189,13 @@ dumpHead HeadTable{..} <> " macStyle bits: " <> "0x" <> dumpFontStyle macStyle <> newlineBuilder <> " lowestRecPPEM " <> Text.Builder.decimal lowestRecPPEM <> newlineBuilder <> " fontDirectionHint " <> dumpFontDirectionHint fontDirectionHint <> newlineBuilder - <> " indexToLocFormat " <> Text.Builder.decimal indexToLocFormat <> newlineBuilder + <> " indexToLocFormat " <> dumpIndexToLocFormat indexToLocFormat <> newlineBuilder <> " glyphDataFormat " <> Text.Builder.decimal glyphDataFormat <> newlineBuilder +dumpIndexToLocFormat :: IndexToLocFormat -> Text.Builder.Builder +dumpIndexToLocFormat ShortOffsetIndexToLocFormat = "0" +dumpIndexToLocFormat LongOffsetIndexToLocFormat = "1" + dumpFontDirectionHint :: FontDirectionHint -> Text.Builder.Builder dumpFontDirectionHint = \case MixedDirectionalGlyphs -> "0" @@ -303,34 +316,60 @@ dumpCmap CmapTable{..} dumpGlyphAtIndex index element = " glyphIdArray[" <> Text.Builder.decimal index <> "] = " <> Text.Builder.decimal element <> newlineBuilder +dumpLoca :: LocaTable -> Text.Builder.Builder +dumpLoca table = + dumpCaption "'loca' Table - Index to Location" + <> go table + where + go (LongLocaTable elements) = dumpElements elements + go (ShortLocaTable elements) = dumpElements + $ (* 2) + . (fromIntegral :: Word16 -> Word32) + <$> elements + dumpElements elements = + case Vector.unsnoc elements of + Just (init', last') + -> foldMap dumpLocaLine (Vector.indexed init') + <> " Ended at " <> paddedHexadecimal last' + Nothing -> mempty + dumpLocaLine :: Integral a => (Int, a) -> Text.Builder.Builder + dumpLocaLine (index, element) + = " Idx " <> justifyNumber 6 index + <> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder + dumpTables :: Megaparsec.State ByteString Void -> FontDirectory -> Either DumpError Text.Builder.Builder -dumpTables processedState directory@FontDirectory{..} = - findRequired "hhea" hheaTableP >>= traverseDirectory +dumpTables processedState directory@FontDirectory{..} + = parseRequired >>= traverseDirectory where - traverseDirectory parsedHhea = + traverseDirectory parsedRequired = let initial = Right $ dumpOffsetTable directory - in foldl' (go parsedHhea) initial tableDirectory + in foldl' (go parsedRequired) initial tableDirectory + parseRequired = RequiredTables + <$> findRequired "hhea" hheaTableP + <*> findRequired "head" headTableP findRequired tableName parser = let missingError = Left $ DumpRequiredTableMissingError tableName - parseRequired tableEntry = parseTable tableEntry parser processedState - in maybe missingError (first DumpParseError . parseRequired) + parseFound tableEntry = parseTable tableEntry parser processedState + in maybe missingError (first DumpParseError . parseFound) $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory go _ (Left accumulator) _ = Left accumulator - go hheaTable (Right accumulator) tableEntry + go parsedRequired (Right accumulator) tableEntry = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) - $ dumpSubTable hheaTable tableEntry + $ dumpSubTable parsedRequired tableEntry concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) <$> builderDump - dumpSubTable hheaTable@HheaTable{ numOfLongHorMetrics } tableEntry = + dumpSubTable RequiredTables{..} tableEntry = case getField @"tag" tableEntry of "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState - "head" -> Just $ dumpHead <$> parseTable tableEntry headTableP processedState + "head" -> Just $ Right $ dumpHead headTable "hhea" -> Just $ Right $ dumpHhea hheaTable "hmtx" -> Just $ dumpHmtx - <$> parseTable tableEntry (hmtxTableP numOfLongHorMetrics) processedState + <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState + "loca" -> Just $ dumpLoca + <$> parseTable tableEntry (locaTableP $ getField @"indexToLocFormat" headTable) processedState _ -> Nothing dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs index 96209f7..209faa2 100644 --- a/src/Graphics/Fountainhead/Parser.hs +++ b/src/Graphics/Fountainhead/Parser.hs @@ -23,6 +23,7 @@ module Graphics.Fountainhead.Parser , headTableP , hheaTableP , hmtxTableP + , locaTableP , longDateTimeP , longLocaTableP , maxpTableP @@ -107,6 +108,7 @@ import Graphics.Fountainhead.TrueType , HeadTable(..) , HheaTable(..) , HmtxTable(..) + , IndexToLocFormat(..) , LocaTable(..) , LongHorMetric(..) , MaxpTable(..) @@ -293,9 +295,17 @@ headTableP = HeadTable <*> fontStyleP <*> Megaparsec.Binary.word16be <*> fontDirectionHintP - <*> Megaparsec.Binary.word16be + <*> 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 @@ -330,6 +340,10 @@ 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 @@ -587,9 +601,8 @@ simpleGlyphDefinitionP numberOfContours' = do , thisXIsSame = testBit flag 4 , thisYIsSame = testBit flag 5 } - repeat = testBit flag 3 repeatN <- - if repeat + if testBit flag 3 then (1 +) . fromIntegral <$> Megaparsec.Binary.word8 diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs index 0a0bde9..4043098 100644 --- a/src/Graphics/Fountainhead/TrueType.hs +++ b/src/Graphics/Fountainhead/TrueType.hs @@ -49,6 +49,7 @@ module Graphics.Fountainhead.TrueType , HeadTable(..) , HheaTable(..) , HmtxTable(..) + , IndexToLocFormat(..) , LocaTable(..) , LongHorMetric(..) , MaxpTable(..) @@ -180,6 +181,11 @@ data HheaTable = HheaTable -- * Font header table +data IndexToLocFormat + = ShortOffsetIndexToLocFormat + | LongOffsetIndexToLocFormat + deriving (Eq, Show) + data HeadTable = HeadTable { version :: Fixed32 -- ^ 0x00010000 if (version 1.0). , fontRevision :: Fixed32 -- ^ Set by font manufacturer. @@ -196,7 +202,7 @@ data HeadTable = HeadTable , macStyle :: FontStyle , lowestRecPPEM :: Word16 -- ^ Smallest readable size in pixels. , fontDirectionHint :: FontDirectionHint -- ^ 0 Mixed directional glyphs. - , indexToLocFormat :: Word16 -- ^ 0 for short offsets, 1 for long. + , indexToLocFormat :: IndexToLocFormat -- ^ 0 for short offsets, 1 for long. , glyphDataFormat :: Word16 -- ^ 0 for current format. } deriving (Eq, Show)