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