diff --git a/README.md b/README.md index 006cc49..457e673 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# TrueType font parser. +# TrueType font parser Fountainhead is a TrueType and OpenType font parser. Its main purpose is to extract information from the fonts to help to @@ -10,24 +10,27 @@ There is also an executable to dump fonts. ## Installation Add the library as dependency to your project. -Alternatively build and run the executable with: +Alternatively build an executable with: ```sh cabal build ``` -The binary can be executed with: +The binary can be run with: ```sh -cabal run fountainhead -- +cabal run fountainhead -- myfont.ttf ``` or installed locally and executed just as: ```sh -fountainhead +fountainhead myfont.ttf ``` +This command will output the contents of the font in a format similar to +ttfdump from TeXLive. + See ```sh 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 - } + go _ (Left accumulator) _ = Left accumulator + go parsedRequired (Right accumulator) tableEntry + = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) + $ dumpSubTable processedState tableEntry parsedRequired + concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) + <$> builderDump + +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 - go _ (Left accumulator) _ = Left accumulator - go parsedRequired (Right accumulator) tableEntry - = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) - $ dumpSubTable parsedRequired tableEntry - 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 + +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 +type Number = Double + +data FontDescriptorFlag + = FixedPitch + | Serif + | Symbolic + | Script + | Nonsymbolic + | Italic + | AllCap + | SmallCap + | ForceBold + deriving (Eq, Show) + +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 + +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) - -afmKeyString :: Text.Builder.Builder -> String -> Text.Builder.Builder -afmKeyString key value = key <> Text.Builder.singleton '\t' - <> Text.Builder.fromString value <> newlineBuilder - -afmFontMetrics :: FontMetrics -> Text.Builder.Builder -afmFontMetrics FontMetrics{..} - = afmKeyString "StartFontMetrics" (showVersion version) - <> afmKeyString "Comment" "Generated by Fountainhead" - <> "EndFontMetrics" <> newlineBuilder 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 diff --git a/src/Main.hs b/src/Main.hs index a87bf85..984f2d7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} module Main ( main ) where @@ -5,49 +6,49 @@ module Main import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.IO as Text.Lazy import Graphics.Fountainhead (dumpFontFile) -import System.Exit (exitWith) -import GHC.IO.Exception (ExitCode(..)) import Options.Applicative - ( Parser - , ParserInfo(..) + ( ParserInfo(..) , (<**>) , argument - , command , execParser + , header + , help , helper , info + , long , fullDesc , metavar + , optional , progDesc + , short , str - , subparser + , strOption ) -data Operation - = Dump - | Afm - deriving (Eq, Show) - -data Options = Options Operation FilePath - deriving (Eq, Show) +data Options = Options + { tableName :: Maybe String + , fontFile :: FilePath + } deriving (Eq, Show) operationOptions :: ParserInfo Options -operationOptions = info (options <**> helper) fullDesc +operationOptions = info (options <**> helper) + $ fullDesc + <> progDesc "Dumping the contents of a TrueType Font file." + <> header "fountainhead - font parser" where options = Options - <$> commands + <$> tableNameArgument <*> argument str (metavar "FONTFILE") - commands = subparser - $ command "dump" (info (pure Dump) (progDesc "Dumping the contents of a TrueType Font file.")) - <> command "afm" (info (pure Afm) (progDesc "Generating Adobe Font Metrics files for TrueType fonts.")) + tableNameArgument = optional $ strOption + $ long "table" + <> short 't' + <> metavar "tablename" + <> help "Dump only the specified table. Otherwise dump all tables" main :: IO () main = execParser operationOptions >>= handleArguments where - handleArguments (Options Dump fontFile) + handleArguments Options{..} = putStrLn ("Dumping File:" <> fontFile <> "\n\n") - >> dumpFontFile fontFile + >> dumpFontFile fontFile tableName >>= either print (Text.Lazy.putStrLn . Text.Builder.toLazyText) - handleArguments (Options Afm _) - = putStrLn "The program expects exactly one argument, the font file path." - >> exitWith (ExitFailure 2)