diff --git a/app/Main.hs b/app/Main.hs index afdee16..b79acaa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,36 +2,52 @@ module Main ( main ) where -import Data.Bifunctor (Bifunctor(..)) -import qualified Text.Megaparsec as Megaparsec import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.IO as Text.Lazy -import Graphics.Fountainhead (parseFontDirectoryFromFile) -import Graphics.Fountainhead.Dumper (DumpError(..), dumpTables) --- TODO: kern table since format 1. --- For details on subtable format see examples in TrueType reference. -import System.Environment (getArgs) +import Graphics.Fountainhead (dumpFontFile) import System.Exit (exitWith) import GHC.IO.Exception (ExitCode(..)) +import Options.Applicative + ( Parser + , ParserInfo(..) + , argument + , command + , execParser + , info + , fullDesc + , metavar + , progDesc + , str + , subparser + ) -fontMain :: FilePath -> IO () -fontMain fontFile = do - putStrLn ("Dumping File:" <> fontFile <> "\n\n") +data Operation + = Dump FilePath + | Afm FilePath + deriving (Eq, Show) - (processedState, initialResult) <- parseFontDirectoryFromFile fontFile +dump :: Parser Operation +dump = Dump + <$> argument str (metavar "FONTFILE") - case first DumpParseError initialResult >>= dumpTables processedState of - Right fontDump -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump - Left e - | DumpParseError bundle <- e -> putStr - $ Megaparsec.errorBundlePretty bundle - | DumpRequiredTableMissingError tableName <- e -> putStr - $ "Required table " <> tableName <> " is missing." +afm :: Parser Operation +afm = Afm + <$> argument str (metavar "FONTFILE") + +operationOptions :: ParserInfo Operation +operationOptions = info commands fullDesc + where + commands = subparser + $ command "dump" (info dump (progDesc "Dumping the contents of a TrueType Font file")) + <> command "afm" (info afm (progDesc "Generating Adobe Font Metrics files for TrueType fonts")) main :: IO () -main = do - programArguments <- getArgs - case programArguments of - [fontFile] -> fontMain fontFile - _ -> putStrLn "The program expects exactly one argument, the font file path." - >> exitWith (ExitFailure 2) +main = execParser operationOptions >>= handleArguments + where + handleArguments (Dump fontFile) + = putStrLn ("Dumping File:" <> fontFile <> "\n\n") + >> dumpFontFile fontFile + >>= either print (Text.Lazy.putStrLn . Text.Builder.toLazyText) + handleArguments (Afm _) + = putStrLn "The program expects exactly one argument, the font file path." + >> exitWith (ExitFailure 2) diff --git a/fountainhead.cabal b/fountainhead.cabal index 1271e18..c213d27 100644 --- a/fountainhead.cabal +++ b/fountainhead.cabal @@ -12,7 +12,7 @@ author: Eugen Wissner license-files: LICENSE license: MPL-2.0 -copyright: (c) 2023 Eugen Wissner +copyright: (c) 2024 Eugen Wissner category: Graphics extra-source-files: @@ -21,6 +21,7 @@ extra-source-files: common dependencies build-depends: + base >= 4.16 && < 5, bytestring ^>= 0.11.0, text ^>= 2.0, zlib ^>= 0.6.3 @@ -30,13 +31,13 @@ library import: dependencies exposed-modules: Graphics.Fountainhead + Graphics.Fountainhead.Compression Graphics.Fountainhead.Dumper Graphics.Fountainhead.Parser Graphics.Fountainhead.Type Graphics.Fountainhead.TrueType - hs-source-dirs: src + hs-source-dirs: lib build-depends: - base >= 4.16 && < 5, containers ^>= 0.6.5, megaparsec ^>= 9.3, time ^>= 1.12, @@ -53,13 +54,13 @@ executable fountainhead DuplicateRecordFields ExplicitForAll build-depends: - base, containers, + fountainhead, + megaparsec, + optparse-applicative ^>= 0.18.1, parser-combinators, vector, transformers, - time, - megaparsec, - fountainhead + time hs-source-dirs: app ghc-options: -Wall diff --git a/src/Graphics/Fountainhead.hs b/lib/Graphics/Fountainhead.hs similarity index 61% rename from src/Graphics/Fountainhead.hs rename to lib/Graphics/Fountainhead.hs index f965680..3852d51 100644 --- a/src/Graphics/Fountainhead.hs +++ b/lib/Graphics/Fountainhead.hs @@ -2,28 +2,31 @@ 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/. -} +-- | Convenience wrappers for working with font files. module Graphics.Fountainhead - ( parseFontDirectoryFromFile + ( dumpFontFile + , parseFontDirectoryFromFile ) where -import qualified Codec.Compression.Zlib as Zlib import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.Void (Void) +import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..)) import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP) import Graphics.Fountainhead.TrueType (FontDirectory(..)) import qualified Text.Megaparsec as Megaparsec import Text.Megaparsec (PosState(..), State(..)) -import System.IO (IOMode(..), SeekMode(..), hFileSize, hSeek, withBinaryFile) +import System.IO (IOMode(..), withBinaryFile) +import Data.Bifunctor (Bifunctor(..)) +import qualified Data.Text.Lazy.Builder as Text.Builder +import Graphics.Fountainhead.Compression (hDecompress) -parseFontDirectoryFromFile :: String +parseFontDirectoryFromFile :: FilePath -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory) parseFontDirectoryFromFile fontFile = withBinaryFile fontFile ReadMode withFontHandle where withFontHandle fontHandle = doParsing - <$> readFontContents fontHandle + <$> hDecompress fontHandle doParsing ttfContents = let initialState = Megaparsec.State { stateInput = ttfContents @@ -38,13 +41,9 @@ parseFontDirectoryFromFile fontFile = , stateParseErrors = [] } in Megaparsec.runParser' fontDirectoryP initialState - readFontContents fontHandle = do - firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2 - hSeek fontHandle AbsoluteSeek 0 - fileSize <- fromIntegral <$> hFileSize fontHandle - case firstBytes of - 0x78 : [secondByte] - | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] -> - ByteString.Lazy.toStrict . Zlib.decompress - <$> ByteString.Lazy.hGet fontHandle fileSize - _ -> ByteString.hGetContents fontHandle + +dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder) +dumpFontFile fontFile = do + (processedState, initialResult) <- parseFontDirectoryFromFile fontFile + + pure $ first DumpParseError initialResult >>= dumpTables processedState diff --git a/lib/Graphics/Fountainhead/Compression.hs b/lib/Graphics/Fountainhead/Compression.hs new file mode 100644 index 0000000..c1a05fc --- /dev/null +++ b/lib/Graphics/Fountainhead/Compression.hs @@ -0,0 +1,27 @@ +-- | Font compression and decompression. +module Graphics.Fountainhead.Compression + ( compress + , hDecompress + ) where + +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Codec.Compression.Zlib as Zlib +import System.IO (Handle, SeekMode(..), hFileSize, hSeek) + +-- | Reads the font from a file handle decompressing it if needed. +hDecompress :: Handle -> IO ByteString +hDecompress fontHandle = do + firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2 + hSeek fontHandle AbsoluteSeek 0 + fileSize <- fromIntegral <$> hFileSize fontHandle + case firstBytes of + 0x78 : [secondByte] + | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] -> + ByteString.Lazy.toStrict . Zlib.decompress + <$> ByteString.Lazy.hGet fontHandle fileSize + _ -> ByteString.hGetContents fontHandle + +compress :: ByteString -> ByteString +compress = ByteString.Lazy.toStrict . Zlib.compress . ByteString.Lazy.fromStrict diff --git a/src/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs similarity index 99% rename from src/Graphics/Fountainhead/Dumper.hs rename to lib/Graphics/Fountainhead/Dumper.hs index adda06f..bbb17c2 100644 --- a/src/Graphics/Fountainhead/Dumper.hs +++ b/lib/Graphics/Fountainhead/Dumper.hs @@ -127,6 +127,13 @@ import Prelude hiding (repeat) data DumpError = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) | DumpRequiredTableMissingError String + deriving Eq + +instance Show DumpError + where + show (DumpParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle + show (DumpRequiredTableMissingError tableName) = + "Required table " <> tableName <> " is missing." data RequiredTables = RequiredTables { hheaTable :: HheaTable diff --git a/src/Graphics/Fountainhead/Parser.hs b/lib/Graphics/Fountainhead/Parser.hs similarity index 100% rename from src/Graphics/Fountainhead/Parser.hs rename to lib/Graphics/Fountainhead/Parser.hs diff --git a/src/Graphics/Fountainhead/TrueType.hs b/lib/Graphics/Fountainhead/TrueType.hs similarity index 100% rename from src/Graphics/Fountainhead/TrueType.hs rename to lib/Graphics/Fountainhead/TrueType.hs diff --git a/src/Graphics/Fountainhead/Type.hs b/lib/Graphics/Fountainhead/Type.hs similarity index 100% rename from src/Graphics/Fountainhead/Type.hs rename to lib/Graphics/Fountainhead/Type.hs