summaryrefslogtreecommitdiff
path: root/lib/Graphics/Fountainhead
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Graphics/Fountainhead')
-rw-r--r--lib/Graphics/Fountainhead/Dumper.hs50
-rw-r--r--lib/Graphics/Fountainhead/Metrics.hs35
-rw-r--r--lib/Graphics/Fountainhead/Parser.hs24
-rw-r--r--lib/Graphics/Fountainhead/TrueType.hs9
-rw-r--r--lib/Graphics/Fountainhead/Type.hs5
5 files changed, 81 insertions, 42 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
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'
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 21:27:20 +0000