fountainhead/app/Main.hs

53 lines
1.8 KiB
Haskell
Raw Normal View History

2023-03-14 09:52:02 +01:00
module Main
( main
) where
import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import qualified Text.Megaparsec as Megaparsec
import Data.Foldable (find)
-- TODO: kern table since format 1.
-- For details on subtable format see examples in TrueType reference.
import Graphics.Fountainhead.Parser
( fontDirectoryP
, os2TableP
, parseTable
, shortLocaTableP
)
import Graphics.Fountainhead.TrueType (FontDirectory(..), TableDirectory(..))
import System.Environment (getArgs)
2023-11-10 11:57:08 +01:00
import System.Exit (exitWith)
import GHC.IO.Exception (ExitCode(..))
2023-03-14 09:52:02 +01:00
2023-11-10 11:57:08 +01:00
fontMain :: FilePath -> IO ()
fontMain fontFile = do
2023-03-14 09:52:02 +01:00
ttfContents <- ByteString.readFile fontFile
let initialState = Megaparsec.State
{ stateInput = ttfContents
, stateOffset = 0
, statePosState = Megaparsec.PosState
{ pstateInput = ttfContents
, pstateOffset = 0
, pstateSourcePos = Megaparsec.initialPos fontFile
, pstateTabWidth = Megaparsec.defaultTabWidth
, pstateLinePrefix = ""
}
, stateParseErrors = []
}
(processedState, Right directory) = Megaparsec.runParser' fontDirectoryP initialState
print directory
let Just tableDirectory' = find (("OS/2" ==) . tag) $ tableDirectory directory
tableResult = parseTable tableDirectory' os2TableP processedState
case tableResult of
Left e -> putStr (Megaparsec.errorBundlePretty e)
Right x -> print x
main :: IO ()
2023-11-10 11:57:08 +01:00
main = do
programArguments <- getArgs
case programArguments of
[fontFile] -> fontMain fontFile
_ -> putStrLn "The program expects exactly one argument, the font file path."
>> exitWith (ExitFailure 2)