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

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)

fontMain :: IO ()
fontMain = do
    fontFile <- head <$> getArgs
    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 = fontMain