summaryrefslogtreecommitdiff
path: root/lib/Graphics
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Graphics')
-rw-r--r--lib/Graphics/Fountainhead.hs10
-rw-r--r--lib/Graphics/Fountainhead/Dumper.hs102
-rw-r--r--lib/Graphics/Fountainhead/Metrics.hs73
-rw-r--r--lib/Graphics/Fountainhead/Parser.hs4
4 files changed, 131 insertions, 58 deletions
diff --git a/lib/Graphics/Fountainhead.hs b/lib/Graphics/Fountainhead.hs
index 3852d51..8e36517 100644
--- a/lib/Graphics/Fountainhead.hs
+++ b/lib/Graphics/Fountainhead.hs
@@ -10,7 +10,7 @@ module Graphics.Fountainhead
import Data.ByteString (ByteString)
import Data.Void (Void)
-import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..))
+import Graphics.Fountainhead.Dumper (dumpTable, dumpTables, DumpError(..))
import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
import Graphics.Fountainhead.TrueType (FontDirectory(..))
import qualified Text.Megaparsec as Megaparsec
@@ -42,8 +42,8 @@ parseFontDirectoryFromFile fontFile =
}
in Megaparsec.runParser' fontDirectoryP initialState
-dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
-dumpFontFile fontFile = do
+dumpFontFile :: FilePath -> Maybe String -> IO (Either DumpError Text.Builder.Builder)
+dumpFontFile fontFile tableName = do
+ let dumpRequest = maybe dumpTables dumpTable tableName
(processedState, initialResult) <- parseFontDirectoryFromFile fontFile
-
- pure $ first DumpParseError initialResult >>= dumpTables processedState
+ pure $ first DumpParseError initialResult >>= dumpRequest processedState
diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs
index c3ba277..d3e2eec 100644
--- a/lib/Graphics/Fountainhead/Dumper.hs
+++ b/lib/Graphics/Fountainhead/Dumper.hs
@@ -14,6 +14,7 @@
module Graphics.Fountainhead.Dumper
( DumpError(..)
, dumpCmap
+ , dumpGASP
, dumpGlyf
, dumpHead
, dumpHmtx
@@ -23,6 +24,7 @@ module Graphics.Fountainhead.Dumper
, dumpMaxp
, dumpOs2
, dumpPost
+ , dumpTable
, dumpTables
, dumpTrueType
, dumpOffsetTable
@@ -95,7 +97,9 @@ import Graphics.Fountainhead.TrueType
)
import qualified Text.Megaparsec as Megaparsec
import Graphics.Fountainhead.Parser
- ( fontDirectoryP
+ ( ParseErrorBundle
+ , ParseState
+ , fontDirectoryP
, parseTable
, cmapTableP
, headTableP
@@ -128,6 +132,7 @@ import Prelude hiding (repeat)
data DumpError
= DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
| DumpRequiredTableMissingError String
+ | DumpRequestedTableMissingError String
deriving Eq
instance Show DumpError
@@ -135,6 +140,8 @@ instance Show DumpError
show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
show (DumpRequiredTableMissingError tableName) =
"Required table " <> tableName <> " is missing."
+ show (DumpRequestedTableMissingError tableName) =
+ "Requested table " <> tableName <> " is missing."
data RequiredTables = RequiredTables
{ hheaTable :: HheaTable
@@ -785,53 +792,78 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
= "(" <> justifyNumber 7 coordinateX <> ", "
<> justifyNumber 7 coordinateY <> ")"
+dumpTable
+ :: String
+ -> ParseState
+ -> FontDirectory
+ -> Either DumpError Text.Builder.Builder
+dumpTable needle processedState FontDirectory{..}
+ | Just neededTable <- find ((needle ==) . Char8.unpack . getField @"tag") tableDirectory
+ = parseRequired processedState tableDirectory
+ >>= maybe (pure mempty) (first DumpParseError)
+ . dumpSubTable processedState neededTable
+ | otherwise = Left $ DumpRequestedTableMissingError needle
+
dumpTables
- :: Megaparsec.State ByteString Void
+ :: ParseState
-> FontDirectory
-> Either DumpError Text.Builder.Builder
dumpTables processedState directory@FontDirectory{..}
- = parseRequired >>= traverseDirectory
+ = parseRequired processedState tableDirectory >>= traverseDirectory
where
traverseDirectory parsedRequired =
let initial = Right $ dumpOffsetTable directory
in foldl' (go parsedRequired) initial tableDirectory
- parseRequired = do
- requiredHhea <- findRequired "hhea" hheaTableP
- requiredHead@HeadTable{ indexToLocFormat } <-
- findRequired "head" headTableP
- requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
- pure $ RequiredTables
- { hheaTable = requiredHhea
- , headTable = requiredHead
- , locaTable = requiredLoca
- }
- findRequired tableName parser =
- let missingError = Left $ DumpRequiredTableMissingError tableName
- parseFound tableEntry = parseTable tableEntry parser processedState
- in maybe missingError (first DumpParseError . parseFound)
- $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory
go _ (Left accumulator) _ = Left accumulator
go parsedRequired (Right accumulator) tableEntry
= maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
- $ dumpSubTable parsedRequired tableEntry
+ $ dumpSubTable processedState tableEntry parsedRequired
concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
<$> builderDump
- dumpSubTable RequiredTables{..} tableEntry =
- case getField @"tag" tableEntry of
- "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
- "head" -> Just $ Right $ dumpHead headTable
- "hhea" -> Just $ Right $ dumpHhea hheaTable
- "hmtx" -> Just $ dumpHmtx
- <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
- "loca" -> Just $ Right $ dumpLoca locaTable
- "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
- "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
- "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
- "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
- "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
- "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState
- "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState
- _ -> Nothing
+
+parseRequired
+ :: (Foldable t)
+ => ParseState
+ -> t TableDirectory
+ -> Either DumpError RequiredTables
+parseRequired processedState tableDirectory = do
+ requiredHhea <- findRequired "hhea" hheaTableP
+ requiredHead@HeadTable{ indexToLocFormat } <-
+ findRequired "head" headTableP
+ requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
+ pure $ RequiredTables
+ { hheaTable = requiredHhea
+ , headTable = requiredHead
+ , locaTable = requiredLoca
+ }
+ where
+ findRequired tableName parser =
+ let missingError = Left $ DumpRequiredTableMissingError tableName
+ parseFound tableEntry = parseTable tableEntry parser processedState
+ in maybe missingError (first DumpParseError . parseFound)
+ $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory
+
+dumpSubTable
+ :: ParseState
+ -> TableDirectory
+ -> RequiredTables
+ -> Maybe (Either ParseErrorBundle Text.Builder.Builder)
+dumpSubTable processedState tableEntry RequiredTables{..} =
+ case getField @"tag" tableEntry of
+ "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
+ "head" -> Just $ Right $ dumpHead headTable
+ "hhea" -> Just $ Right $ dumpHhea hheaTable
+ "hmtx" -> Just $ dumpHmtx
+ <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
+ "loca" -> Just $ Right $ dumpLoca locaTable
+ "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
+ "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
+ "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
+ "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
+ "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
+ "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 =
diff --git a/lib/Graphics/Fountainhead/Metrics.hs b/lib/Graphics/Fountainhead/Metrics.hs
index bb50b93..abf80b7 100644
--- a/lib/Graphics/Fountainhead/Metrics.hs
+++ b/lib/Graphics/Fountainhead/Metrics.hs
@@ -3,27 +3,66 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
module Graphics.Fountainhead.Metrics
- ( FontMetrics(..)
- , afmFontMetrics
+ ( FontBBox(..)
+ , FontDescriptor(..)
+ , Number
+ , FontDescriptorFlag(..)
) where
-import qualified Data.Text.Lazy.Builder as Text.Builder
-import Data.Version (Version(..), showVersion)
-import Graphics.Fountainhead.Type (newlineBuilder)
+import Data.Text (Text)
-newtype FontMetrics = FontMetrics
- { version :: Version
- } deriving (Eq, Show)
+type Number = Double
+
+data FontDescriptorFlag
+ = FixedPitch
+ | Serif
+ | Symbolic
+ | Script
+ | Nonsymbolic
+ | Italic
+ | AllCap
+ | SmallCap
+ | ForceBold
+ deriving (Eq, Show)
-afmKeyString :: Text.Builder.Builder -> String -> Text.Builder.Builder
-afmKeyString key value = key <> Text.Builder.singleton '\t'
- <> Text.Builder.fromString value <> newlineBuilder
+instance Enum FontDescriptorFlag
+ where
+ toEnum 1 = FixedPitch
+ toEnum 2 = Serif
+ toEnum 3 = Symbolic
+ toEnum 4 = Script
+ toEnum 6 = Nonsymbolic
+ toEnum 7 = Italic
+ toEnum 17 = AllCap
+ toEnum 18 = SmallCap
+ toEnum 19 = ForceBold
+ toEnum _ = error "Font description flag is not supported."
+ fromEnum FixedPitch = 1
+ fromEnum Serif = 2
+ fromEnum Symbolic = 3
+ fromEnum Script = 4
+ fromEnum Nonsymbolic = 6
+ fromEnum Italic = 7
+ fromEnum AllCap = 17
+ fromEnum SmallCap = 18
+ fromEnum ForceBold = 19
-afmFontMetrics :: FontMetrics -> Text.Builder.Builder
-afmFontMetrics FontMetrics{..}
- = afmKeyString "StartFontMetrics" (showVersion version)
- <> afmKeyString "Comment" "Generated by Fountainhead"
- <> "EndFontMetrics" <> newlineBuilder
+data FontBBox = FontBBox Number Number Number Number
+ deriving (Eq, Show)
+
+data FontDescriptor = FontDescriptor
+ { fontName :: Text
+ , flags :: [FontDescriptorFlag]
+ , fullName :: Text
+ , familyName :: Text
+ , weight :: Text
+ , fontBBox :: FontBBox
+ , version :: Text
+ , notice :: Text
+ , encodingScheme :: Text
+ , isFixedPitch :: Bool
+ , ascender :: Number
+ , descender :: Number
+ } deriving (Eq, Show)
diff --git a/lib/Graphics/Fountainhead/Parser.hs b/lib/Graphics/Fountainhead/Parser.hs
index 31dcd0e..672f9fc 100644
--- a/lib/Graphics/Fountainhead/Parser.hs
+++ b/lib/Graphics/Fountainhead/Parser.hs
@@ -13,6 +13,7 @@
module Graphics.Fountainhead.Parser
( Parser
, ParseErrorBundle
+ , ParseState
, cmapTableP
, cvTableP
, f2Dot14P
@@ -154,6 +155,7 @@ import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary
type Parser = Megaparsec.Parsec Void ByteString
type ParseErrorBundle = Megaparsec.ParseErrorBundle ByteString Void
+type ParseState = Megaparsec.State ByteString Void
-- * Font directory
@@ -953,7 +955,7 @@ fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be
parseTable
:: TableDirectory
-> Parser a
- -> Megaparsec.State ByteString Void
+ -> ParseState
-> Either ParseErrorBundle a
parseTable TableDirectory{ offset, length = length' } parser state = snd
$ Megaparsec.runParser' parser
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:23:10 +0000