From c5f715ac7cdfb663fc84cb9fe841903b5aed99c5 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 7 Feb 2024 10:40:00 +0100 Subject: [PATCH] Extract some convenience parsing functions --- fountainhead.cabal | 12 ++++++ lib/Graphics/Fountainhead.hs | 31 ++++---------- lib/Graphics/Fountainhead/Dumper.hs | 50 ++++++----------------- lib/Graphics/Fountainhead/Metrics.hs | 35 ++++++++++++++++ lib/Graphics/Fountainhead/Parser.hs | 24 +++++++++++ lib/Graphics/Fountainhead/TrueType.hs | 9 ++++ lib/Graphics/Fountainhead/Type.hs | 5 --- test/Graphics/Fountainhead/MetricsSpec.hs | 32 +++++++++++++++ test/Spec.hs | 5 +++ 9 files changed, 139 insertions(+), 64 deletions(-) create mode 100644 test/Graphics/Fountainhead/MetricsSpec.hs create mode 100644 test/Spec.hs diff --git a/fountainhead.cabal b/fountainhead.cabal index 7af36e5..8acb0c1 100644 --- a/fountainhead.cabal +++ b/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 diff --git a/lib/Graphics/Fountainhead.hs b/lib/Graphics/Fountainhead.hs index 8e36517..fd46777 100644 --- a/lib/Graphics/Fountainhead.hs +++ b/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 (PosState(..), State(..)) +import Text.Megaparsec (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 = - withBinaryFile fontFile ReadMode withFontHandle - 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 +parseFontDirectoryFromFile fontFile = withBinaryFile fontFile ReadMode + $ fmap (parseFontDirectory fontFile) . hDecompress +-- | 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 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 diff --git a/lib/Graphics/Fountainhead/Metrics.hs b/lib/Graphics/Fountainhead/Metrics.hs index abf80b7..ddebf85 100644 --- a/lib/Graphics/Fountainhead/Metrics.hs +++ b/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" diff --git a/lib/Graphics/Fountainhead/Parser.hs b/lib/Graphics/Fountainhead/Parser.hs index 672f9fc..5c437d6 100644 --- a/lib/Graphics/Fountainhead/Parser.hs +++ b/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 diff --git a/lib/Graphics/Fountainhead/TrueType.hs b/lib/Graphics/Fountainhead/TrueType.hs index 0c15081..55d55ae 100644 --- a/lib/Graphics/Fountainhead/TrueType.hs +++ b/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 diff --git a/lib/Graphics/Fountainhead/Type.hs b/lib/Graphics/Fountainhead/Type.hs index beaf6e4..e809d9c 100644 --- a/lib/Graphics/Fountainhead/Type.hs +++ b/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' diff --git a/test/Graphics/Fountainhead/MetricsSpec.hs b/test/Graphics/Fountainhead/MetricsSpec.hs new file mode 100644 index 0000000..d122579 --- /dev/null +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..feacffa --- /dev/null +++ b/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 #-}