Add font compression

This commit is contained in:
Eugen Wissner 2024-02-03 11:58:47 +01:00
parent 34d3ece99e
commit a34b46e1b5
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
8 changed files with 98 additions and 48 deletions

View File

@ -2,36 +2,52 @@ module Main
( main ( main
) where ) 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.Builder as Text.Builder
import qualified Data.Text.Lazy.IO as Text.Lazy import qualified Data.Text.Lazy.IO as Text.Lazy
import Graphics.Fountainhead (parseFontDirectoryFromFile) import Graphics.Fountainhead (dumpFontFile)
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 System.Exit (exitWith) import System.Exit (exitWith)
import GHC.IO.Exception (ExitCode(..)) import GHC.IO.Exception (ExitCode(..))
import Options.Applicative
( Parser
, ParserInfo(..)
, argument
, command
, execParser
, info
, fullDesc
, metavar
, progDesc
, str
, subparser
)
fontMain :: FilePath -> IO () data Operation
fontMain fontFile = do = Dump FilePath
putStrLn ("Dumping File:" <> fontFile <> "\n\n") | 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 afm :: Parser Operation
Right fontDump -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump afm = Afm
Left e <$> argument str (metavar "FONTFILE")
| DumpParseError bundle <- e -> putStr
$ Megaparsec.errorBundlePretty bundle operationOptions :: ParserInfo Operation
| DumpRequiredTableMissingError tableName <- e -> putStr operationOptions = info commands fullDesc
$ "Required table " <> tableName <> " is missing." 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 :: IO ()
main = do main = execParser operationOptions >>= handleArguments
programArguments <- getArgs where
case programArguments of handleArguments (Dump fontFile)
[fontFile] -> fontMain fontFile = putStrLn ("Dumping File:" <> fontFile <> "\n\n")
_ -> putStrLn "The program expects exactly one argument, the font file path." >> 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) >> exitWith (ExitFailure 2)

View File

@ -12,7 +12,7 @@ author: Eugen Wissner
license-files: LICENSE license-files: LICENSE
license: MPL-2.0 license: MPL-2.0
copyright: (c) 2023 Eugen Wissner copyright: (c) 2024 Eugen Wissner
category: Graphics category: Graphics
extra-source-files: extra-source-files:
@ -21,6 +21,7 @@ extra-source-files:
common dependencies common dependencies
build-depends: build-depends:
base >= 4.16 && < 5,
bytestring ^>= 0.11.0, bytestring ^>= 0.11.0,
text ^>= 2.0, text ^>= 2.0,
zlib ^>= 0.6.3 zlib ^>= 0.6.3
@ -30,13 +31,13 @@ library
import: dependencies import: dependencies
exposed-modules: exposed-modules:
Graphics.Fountainhead Graphics.Fountainhead
Graphics.Fountainhead.Compression
Graphics.Fountainhead.Dumper Graphics.Fountainhead.Dumper
Graphics.Fountainhead.Parser Graphics.Fountainhead.Parser
Graphics.Fountainhead.Type Graphics.Fountainhead.Type
Graphics.Fountainhead.TrueType Graphics.Fountainhead.TrueType
hs-source-dirs: src hs-source-dirs: lib
build-depends: build-depends:
base >= 4.16 && < 5,
containers ^>= 0.6.5, containers ^>= 0.6.5,
megaparsec ^>= 9.3, megaparsec ^>= 9.3,
time ^>= 1.12, time ^>= 1.12,
@ -53,13 +54,13 @@ executable fountainhead
DuplicateRecordFields DuplicateRecordFields
ExplicitForAll ExplicitForAll
build-depends: build-depends:
base,
containers, containers,
fountainhead,
megaparsec,
optparse-applicative ^>= 0.18.1,
parser-combinators, parser-combinators,
vector, vector,
transformers, transformers,
time, time
megaparsec,
fountainhead
hs-source-dirs: app hs-source-dirs: app
ghc-options: -Wall ghc-options: -Wall

View File

@ -2,28 +2,31 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can 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/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
-- | Convenience wrappers for working with font files.
module Graphics.Fountainhead module Graphics.Fountainhead
( parseFontDirectoryFromFile ( dumpFontFile
, parseFontDirectoryFromFile
) where ) where
import qualified Codec.Compression.Zlib as Zlib
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteString.Lazy
import Data.Void (Void) import Data.Void (Void)
import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..))
import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP) import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
import Graphics.Fountainhead.TrueType (FontDirectory(..)) import Graphics.Fountainhead.TrueType (FontDirectory(..))
import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec as Megaparsec
import Text.Megaparsec (PosState(..), State(..)) 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) -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
parseFontDirectoryFromFile fontFile = parseFontDirectoryFromFile fontFile =
withBinaryFile fontFile ReadMode withFontHandle withBinaryFile fontFile ReadMode withFontHandle
where where
withFontHandle fontHandle = doParsing withFontHandle fontHandle = doParsing
<$> readFontContents fontHandle <$> hDecompress fontHandle
doParsing ttfContents = doParsing ttfContents =
let initialState = Megaparsec.State let initialState = Megaparsec.State
{ stateInput = ttfContents { stateInput = ttfContents
@ -38,13 +41,9 @@ parseFontDirectoryFromFile fontFile =
, stateParseErrors = [] , stateParseErrors = []
} }
in Megaparsec.runParser' fontDirectoryP initialState in Megaparsec.runParser' fontDirectoryP initialState
readFontContents fontHandle = do
firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2 dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
hSeek fontHandle AbsoluteSeek 0 dumpFontFile fontFile = do
fileSize <- fromIntegral <$> hFileSize fontHandle (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
case firstBytes of
0x78 : [secondByte] pure $ first DumpParseError initialResult >>= dumpTables processedState
| secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] ->
ByteString.Lazy.toStrict . Zlib.decompress
<$> ByteString.Lazy.hGet fontHandle fileSize
_ -> ByteString.hGetContents fontHandle

View File

@ -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

View File

@ -127,6 +127,13 @@ import Prelude hiding (repeat)
data DumpError data DumpError
= DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
| DumpRequiredTableMissingError String | 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 data RequiredTables = RequiredTables
{ hheaTable :: HheaTable { hheaTable :: HheaTable