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
) 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."
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)

View File

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

View File

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

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