fountainhead/app/Main.hs

module Main
    ( main
    ) where

import Control.Monad (foldM_)
import Data.Int (Int64)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import Data.ByteString (ByteString)
import qualified Text.Megaparsec as Megaparsec
import Data.Foldable (find)
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.IO as Text.Lazy
import qualified Data.Text.Encoding as Text
import GHC.Records (HasField(..))
import Graphics.Fountainhead.Dumper (dumpTrueType)
-- 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(..)
    , OffsetSubtable(..)
    , TableDirectory(..)
    )
import System.Environment (getArgs)
import System.Exit (exitWith)
import GHC.IO.Exception (ExitCode(..))

fontMain :: FilePath -> IO ()
fontMain fontFile = do
    putStrLn $ "Dumping File:" <> fontFile <> "\n\n"

    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, initialResult) = Megaparsec.runParser' fontDirectoryP initialState 
    
    case initialResult >>= dumpTrueType processedState of
        (Right fontDump) -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump
        Left e -> putStr (Megaparsec.errorBundlePretty e)
    {-
    let Just tableDirectory' = find (("OS/2" ==) . tag) $ tableDirectory directory
        tableResult = parseTable tableDirectory' os2TableP processedState
    case tableResult of
        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)