Extract some convenience parsing functions

fountainhead.cabal

@@ -65,3 +65,15 @@ executable fountainhead
     time
   hs-source-dirs: src
   ghc-options: -Wall
+
+test-suite fountainhead-test
+  import: dependencies
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs: test
+  other-modules:
+    Graphics.Fountainhead.MetricsSpec
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+    fountainhead,
+    hspec >= 2.9 && < 3

lib/Graphics/Fountainhead.hs

@@ -11,37 +11,24 @@ module Graphics.Fountainhead
 import Data.ByteString (ByteString)
 import Data.Void (Void)
 import Graphics.Fountainhead.Dumper (dumpTable, dumpTables, DumpError(..))
-import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
+import Graphics.Fountainhead.Parser (ParseErrorBundle, parseFontDirectory)
 import Graphics.Fountainhead.TrueType (FontDirectory(..))
-import qualified Text.Megaparsec as Megaparsec
+import Text.Megaparsec (State(..))
-import Text.Megaparsec (PosState(..), State(..))
 import System.IO (IOMode(..), withBinaryFile)
 import Data.Bifunctor (Bifunctor(..))
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import Graphics.Fountainhead.Compression (hDecompress)
 
+-- | Does initial parsing of the font at the given path and returns the font
+-- directory and parsing state that can be used to parse other tables in the
+-- font.
 parseFontDirectoryFromFile :: FilePath
     -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
-parseFontDirectoryFromFile fontFile =
+parseFontDirectoryFromFile fontFile = withBinaryFile fontFile ReadMode
-    withBinaryFile fontFile ReadMode withFontHandle
+    $ fmap (parseFontDirectory fontFile) . hDecompress
-  where
-    withFontHandle fontHandle = doParsing
-        <$> hDecompress fontHandle
-    doParsing ttfContents =
-        let initialState = Megaparsec.State
-                { stateInput = ttfContents
-                , stateOffset = 0
-                , statePosState = Megaparsec.PosState
-                    { pstateInput = ttfContents
-                    , pstateOffset = 0
-                    , pstateSourcePos = Megaparsec.initialPos fontFile
-                    , pstateTabWidth = Megaparsec.defaultTabWidth
-                    , pstateLinePrefix = ""
-                    }
-                , stateParseErrors = []
-                }
-         in Megaparsec.runParser' fontDirectoryP initialState 
 
+-- | Dumps the contents of the font in the file. If the table name is given,
+-- dumps only this one table.
 dumpFontFile :: FilePath -> Maybe String -> IO (Either DumpError Text.Builder.Builder)
 dumpFontFile fontFile tableName = do
     let dumpRequest = maybe dumpTables dumpTable tableName

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{..}
+dumpTable needle processedState fontDirectory
-    | Just neededTable <- find ((needle ==) . Char8.unpack . getField @"tag") tableDirectory
+    | Just neededTable <- findTableByTag needle fontDirectory
-        = parseRequired processedState tableDirectory
+        = 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
+parseRequired :: ParseState -> FontDirectory -> Either DumpError RequiredTables
-    :: (Foldable t)
+parseRequired processedState fontDirectory = do
-    => ParseState
-    -> t TableDirectory
-    -> Either DumpError RequiredTables
-parseRequired processedState tableDirectory = 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

lib/Graphics/Fountainhead/Metrics.hs

@@ -7,11 +7,22 @@
 module Graphics.Fountainhead.Metrics
     ( FontBBox(..)
     , FontDescriptor(..)
+    , MetricsError(..)
     , Number
     , FontDescriptorFlag(..)
+    , collectMetrics
     ) where
 
+import Data.ByteString (ByteString)
 import Data.Text (Text)
+import Graphics.Fountainhead.TrueType (findTableByTag)
+import Graphics.Fountainhead.Parser
+    ( ParseErrorBundle
+    , nameTableP
+    , parseFontDirectory
+    , parseTable
+    )
+import qualified Text.Megaparsec as Megaparsec
 
 type Number = Double
 
@@ -66,3 +77,27 @@ data FontDescriptor = FontDescriptor
     , ascender :: Number
     , descender :: Number
     } deriving (Eq, Show)
+
+data MetricsError
+    = MetricsParseError ParseErrorBundle
+    | MetricsRequiredTableMissingError String
+    deriving Eq
+
+instance Show MetricsError
+  where
+    show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
+    show (MetricsRequiredTableMissingError tableName) =
+        "Required table " <> tableName <> " is missing."
+
+collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
+collectMetrics fontFile ttfContents =
+    case parseFontDirectory fontFile ttfContents of
+        (_processedState, Left initialResult) -> Left
+            $ MetricsParseError initialResult
+        (processedState, Right initialResult)
+            | Just tableEntry <- findTableByTag "name" initialResult
+            , Right parsedNameTable <- parseTable tableEntry nameTableP processedState ->
+                pure $ FontDescriptor
+                    {
+                    }
+            | otherwise -> Left $ MetricsRequiredTableMissingError "name"

lib/Graphics/Fountainhead/Parser.hs

@@ -33,6 +33,7 @@ module Graphics.Fountainhead.Parser
     , nameTableP
     , os2TableP
     , panoseP
+    , parseFontDirectory
     , parseTable
     , pascalStringP
     , postTableP
@@ -157,6 +158,29 @@ type Parser = Megaparsec.Parsec Void ByteString
 type ParseErrorBundle = Megaparsec.ParseErrorBundle ByteString Void
 type ParseState = Megaparsec.State ByteString Void
 
+-- | Does initial parsing and returns the font directory and parsing state
+-- that can be used to parse other tables in the font.
+--
+-- Font file name can be empty.
+parseFontDirectory
+    :: FilePath
+    -> ByteString
+    -> (ParseState, Either ParseErrorBundle FontDirectory)
+parseFontDirectory fontFile ttfContents =
+    let initialState = Megaparsec.State
+            { stateInput = ttfContents
+            , stateOffset = 0
+            , statePosState = Megaparsec.PosState
+                { pstateInput = ttfContents
+                , pstateOffset = 0
+                , pstateSourcePos = Megaparsec.initialPos fontFile
+                , pstateTabWidth = Megaparsec.defaultTabWidth
+                , pstateLinePrefix = ""
+                }
+            , stateParseErrors = []
+            }
+     in Megaparsec.runParser' fontDirectoryP initialState 
+
 -- * Font directory
 
 offsetSubtableP :: Parser OffsetSubtable

lib/Graphics/Fountainhead/TrueType.hs

@@ -2,6 +2,7 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -81,11 +82,13 @@ module Graphics.Fountainhead.TrueType
     , UVSMapping(..)
     , UnicodeValueRange(..)
     , VariationSelectorMap
+    , findTableByTag
     , unLocaTable
     , nameStringOffset
     ) where
 
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as Char8
 import Data.Int (Int8, Int16)
 import Data.IntMap (IntMap)
 import Data.List.NonEmpty (NonEmpty(..))
@@ -93,6 +96,8 @@ import Data.Time (LocalTime(..))
 import Data.Vector (Vector)
 import Data.Word (Word8, Word16, Word32)
 import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), FWord, UFWord)
+import GHC.Records (HasField(..))
+import Data.Foldable (find)
 
 -- * Font directory
 
@@ -101,6 +106,10 @@ data FontDirectory = FontDirectory
     , tableDirectory :: [TableDirectory]
     } deriving (Eq, Show)
 
+findTableByTag :: String -> FontDirectory -> Maybe TableDirectory
+findTableByTag needle = find ((needle ==) . Char8.unpack . getField @"tag")
+    . getField @"tableDirectory"
+
 data OffsetSubtable = OffsetSubtable
     { scalerType :: Word32
     , numTables :: Int

lib/Graphics/Fountainhead/Type.hs

@@ -9,12 +9,10 @@ module Graphics.Fountainhead.Type
     , FWord
     , UFWord
     , fixed2Double
-    , newlineBuilder
     , succIntegral
     , ttfEpoch
     ) where
 
-import qualified Data.Text.Lazy.Builder as Text.Builder
 import Data.Bits ((.>>.), (.&.))
 import Data.Int (Int16)
 import Data.Word (Word16, Word32)
@@ -41,6 +39,3 @@ fixed2Double (F2Dot14 fixed) =
     let mantissa = realToFrac (fixed .>>. 14)
         fraction = realToFrac (fixed .&. 0x3fff) / 16384.0
      in mantissa + fraction
-
-newlineBuilder :: Text.Builder.Builder
-newlineBuilder = Text.Builder.singleton '\n'

test/Graphics/Fountainhead/MetricsSpec.hs

@@ -0,0 +1,32 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Graphics.Fountainhead.MetricsSpec
+    ( spec
+    ) where
+
+import Graphics.Fountainhead.Metrics
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec =
+    describe "collectMetrics" $
+        it "collects information from the name table" $ do
+            let expected = FontDescriptor
+                    { fontName = "fontName"
+                    , flags = []
+                    , fullName = "fullName"
+                    , familyName = "familyName"
+                    , weight = "weight"
+                    , fontBBox =  FontBBox 0 0 0 0
+                    , version = "1.0.0"
+                    , notice = "Notice"
+                    , encodingScheme = "encodingScheme"
+                    , isFixedPitch = False
+                    , ascender = 0
+                    , descender = 0
+                    }
+             in collectMetrics `shouldBe` expected

test/Spec.hs

@@ -0,0 +1,5 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}