app/Main.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

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)
import System.Exit (exitWith)
import GHC.IO.Exception (ExitCode(..))

fontMain :: FilePath -> IO ()
fontMain fontFile = do
    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 ()
main = do
    programArguments <- getArgs
    case programArguments of
        [fontFile] -> fontMain fontFile
        _ -> putStrLn "The program expects exactly one argument, the font file path."
            >> exitWith (ExitFailure 2)