Extract some convenience parsing functions

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