diff options
Diffstat (limited to 'lib/Graphics/Fountainhead/Dumper.hs')
| -rw-r--r-- | lib/Graphics/Fountainhead/Dumper.hs | 50 |
1 files changed, 13 insertions, 37 deletions
diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs index d3e2eec..2a90db5 100644 --- a/lib/Graphics/Fountainhead/Dumper.hs +++ b/lib/Graphics/Fountainhead/Dumper.hs @@ -26,13 +26,10 @@ module Graphics.Fountainhead.Dumper , dumpPost , dumpTable , dumpTables - , dumpTrueType , dumpOffsetTable ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 as Char8 import Data.Int (Int64, Int16) import Data.Word (Word8, Word16, Word32) import qualified Data.IntMap as IntMap @@ -44,7 +41,6 @@ import qualified Data.Text.Lazy.Builder.Int as Text.Builder import qualified Data.Text.Lazy.Builder.RealFloat as Text.Builder import Data.Vector (Vector) import qualified Data.Vector as Vector -import Data.Void import GHC.Records (HasField(..)) import Graphics.Fountainhead.TrueType ( CmapTable(..) @@ -94,12 +90,12 @@ import Graphics.Fountainhead.TrueType , OutlineFlag(..) , ComponentGlyphFlags(..) , GlyphTransformationOption(..) + , findTableByTag ) import qualified Text.Megaparsec as Megaparsec import Graphics.Fountainhead.Parser ( ParseErrorBundle , ParseState - , fontDirectoryP , parseTable , cmapTableP , headTableP @@ -118,10 +114,9 @@ import Graphics.Fountainhead.Type ( Fixed32(..) , succIntegral , ttfEpoch - , newlineBuilder , fixed2Double ) -import Data.Foldable (Foldable(..), find) +import Data.Foldable (Foldable(..)) import Data.Maybe (fromMaybe, catMaybes) import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight) import Data.Bits (Bits(..), (.>>.)) @@ -130,7 +125,7 @@ import Data.List (intersperse) import Prelude hiding (repeat) data DumpError - = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) + = DumpParseError ParseErrorBundle | DumpRequiredTableMissingError String | DumpRequestedTableMissingError String deriving Eq @@ -149,6 +144,9 @@ data RequiredTables = RequiredTables , locaTable :: LocaTable } deriving (Eq, Show) +newlineBuilder :: Text.Builder.Builder +newlineBuilder = Text.Builder.singleton '\n' + paddedHexadecimal :: Integral a => a -> Text.Builder.Builder paddedHexadecimal = ("0x" <>) . Text.Builder.fromLazyText @@ -797,9 +795,9 @@ dumpTable -> ParseState -> FontDirectory -> Either DumpError Text.Builder.Builder -dumpTable needle processedState FontDirectory{..} - | Just neededTable <- find ((needle ==) . Char8.unpack . getField @"tag") tableDirectory - = parseRequired processedState tableDirectory +dumpTable needle processedState fontDirectory + | Just neededTable <- findTableByTag needle fontDirectory + = parseRequired processedState fontDirectory >>= maybe (pure mempty) (first DumpParseError) . dumpSubTable processedState neededTable | otherwise = Left $ DumpRequestedTableMissingError needle @@ -809,7 +807,7 @@ dumpTables -> FontDirectory -> Either DumpError Text.Builder.Builder dumpTables processedState directory@FontDirectory{..} - = parseRequired processedState tableDirectory >>= traverseDirectory + = parseRequired processedState directory >>= traverseDirectory where traverseDirectory parsedRequired = let initial = Right $ dumpOffsetTable directory @@ -821,12 +819,8 @@ dumpTables processedState directory@FontDirectory{..} concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) <$> builderDump -parseRequired - :: (Foldable t) - => ParseState - -> t TableDirectory - -> Either DumpError RequiredTables -parseRequired processedState tableDirectory = do +parseRequired :: ParseState -> FontDirectory -> Either DumpError RequiredTables +parseRequired processedState fontDirectory = do requiredHhea <- findRequired "hhea" hheaTableP requiredHead@HeadTable{ indexToLocFormat } <- findRequired "head" headTableP @@ -841,7 +835,7 @@ parseRequired processedState tableDirectory = do let missingError = Left $ DumpRequiredTableMissingError tableName parseFound tableEntry = parseTable tableEntry parser processedState in maybe missingError (first DumpParseError . parseFound) - $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory + $ findTableByTag tableName fontDirectory dumpSubTable :: ParseState @@ -864,21 +858,3 @@ dumpSubTable processedState tableEntry RequiredTables{..} = "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 = - let initialState = Megaparsec.State - { stateInput = ttfContents - , stateOffset = 0 - , statePosState = Megaparsec.PosState - { pstateInput = ttfContents - , pstateOffset = 0 - , pstateSourcePos = Megaparsec.initialPos fontFile - , pstateTabWidth = Megaparsec.defaultTabWidth - , pstateLinePrefix = "" - } - , stateParseErrors = [] - } - (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState - - in first DumpParseError initialResult >>= dumpTables processedState |