diff options
Diffstat (limited to 'lib/Graphics/Fountainhead/Dumper.hs')
| -rw-r--r-- | lib/Graphics/Fountainhead/Dumper.hs | 102 |
1 files changed, 67 insertions, 35 deletions
diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs index c3ba277..d3e2eec 100644 --- a/lib/Graphics/Fountainhead/Dumper.hs +++ b/lib/Graphics/Fountainhead/Dumper.hs @@ -14,6 +14,7 @@ module Graphics.Fountainhead.Dumper ( DumpError(..) , dumpCmap + , dumpGASP , dumpGlyf , dumpHead , dumpHmtx @@ -23,6 +24,7 @@ module Graphics.Fountainhead.Dumper , dumpMaxp , dumpOs2 , dumpPost + , dumpTable , dumpTables , dumpTrueType , dumpOffsetTable @@ -95,7 +97,9 @@ import Graphics.Fountainhead.TrueType ) import qualified Text.Megaparsec as Megaparsec import Graphics.Fountainhead.Parser - ( fontDirectoryP + ( ParseErrorBundle + , ParseState + , fontDirectoryP , parseTable , cmapTableP , headTableP @@ -128,6 +132,7 @@ import Prelude hiding (repeat) data DumpError = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) | DumpRequiredTableMissingError String + | DumpRequestedTableMissingError String deriving Eq instance Show DumpError @@ -135,6 +140,8 @@ instance Show DumpError show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle show (DumpRequiredTableMissingError tableName) = "Required table " <> tableName <> " is missing." + show (DumpRequestedTableMissingError tableName) = + "Requested table " <> tableName <> " is missing." data RequiredTables = RequiredTables { hheaTable :: HheaTable @@ -785,53 +792,78 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data" = "(" <> justifyNumber 7 coordinateX <> ", " <> justifyNumber 7 coordinateY <> ")" +dumpTable + :: String + -> ParseState + -> FontDirectory + -> Either DumpError Text.Builder.Builder +dumpTable needle processedState FontDirectory{..} + | Just neededTable <- find ((needle ==) . Char8.unpack . getField @"tag") tableDirectory + = parseRequired processedState tableDirectory + >>= maybe (pure mempty) (first DumpParseError) + . dumpSubTable processedState neededTable + | otherwise = Left $ DumpRequestedTableMissingError needle + dumpTables - :: Megaparsec.State ByteString Void + :: ParseState -> FontDirectory -> Either DumpError Text.Builder.Builder dumpTables processedState directory@FontDirectory{..} - = parseRequired >>= traverseDirectory + = parseRequired processedState tableDirectory >>= traverseDirectory where traverseDirectory parsedRequired = let initial = Right $ dumpOffsetTable directory in foldl' (go parsedRequired) initial tableDirectory - parseRequired = do - requiredHhea <- findRequired "hhea" hheaTableP - requiredHead@HeadTable{ indexToLocFormat } <- - findRequired "head" headTableP - requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat) - pure $ RequiredTables - { hheaTable = requiredHhea - , headTable = requiredHead - , locaTable = requiredLoca - } - findRequired tableName parser = - let missingError = Left $ DumpRequiredTableMissingError tableName - 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 parsedRequired (Right accumulator) tableEntry = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) - $ dumpSubTable parsedRequired tableEntry + $ dumpSubTable processedState tableEntry parsedRequired concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) <$> builderDump - dumpSubTable RequiredTables{..} tableEntry = - case getField @"tag" tableEntry of - "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState - "head" -> Just $ Right $ dumpHead headTable - "hhea" -> Just $ Right $ dumpHhea hheaTable - "hmtx" -> Just $ dumpHmtx - <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState - "loca" -> Just $ Right $ dumpLoca locaTable - "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState - "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState - "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState - "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState - "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState - "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState - "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState - _ -> Nothing + +parseRequired + :: (Foldable t) + => ParseState + -> t TableDirectory + -> Either DumpError RequiredTables +parseRequired processedState tableDirectory = do + requiredHhea <- findRequired "hhea" hheaTableP + requiredHead@HeadTable{ indexToLocFormat } <- + findRequired "head" headTableP + requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat) + pure $ RequiredTables + { hheaTable = requiredHhea + , headTable = requiredHead + , locaTable = requiredLoca + } + where + findRequired tableName parser = + let missingError = Left $ DumpRequiredTableMissingError tableName + parseFound tableEntry = parseTable tableEntry parser processedState + in maybe missingError (first DumpParseError . parseFound) + $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory + +dumpSubTable + :: ParseState + -> TableDirectory + -> RequiredTables + -> Maybe (Either ParseErrorBundle Text.Builder.Builder) +dumpSubTable processedState tableEntry RequiredTables{..} = + case getField @"tag" tableEntry of + "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState + "head" -> Just $ Right $ dumpHead headTable + "hhea" -> Just $ Right $ dumpHhea hheaTable + "hmtx" -> Just $ dumpHmtx + <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState + "loca" -> Just $ Right $ dumpLoca locaTable + "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState + "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState + "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState + "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState + "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState + "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState + "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState + _ -> Nothing dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder dumpTrueType ttfContents fontFile = |