~jojo/Carth

ref: ae1d242d7d48292779dcbd953e5864bb4211e1ca Carth/app/Main.hs -rw-r--r-- 2.7 KiB
ae1d242dJoJo Update stackage release & use default-extensions in cabal file 9 months ago
                                                                                
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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
{-# LANGUAGE LambdaCase #-}

module Main (main) where

import System.Environment
import Control.Monad
import Control.Monad.Except
import Prelude hiding (lex)

import Misc
import qualified Err
import qualified Lexd
import qualified Parsed
import qualified Checked
import Check
import Conf
import GetConfig
import Compile
import Monomorphize
import Optimize
import qualified Optimized as Ast
import qualified Parse
import qualified Lex
import qualified Macro
import EnvVars

main :: IO ()
main = getConfig >>= \case
    CompileConf cfg -> compileFile cfg
    RunConf cfg -> runFile cfg

compileFile :: CompileConfig -> IO ()
compileFile cfg = do
    let f = cInfile cfg
    putStrLn ("   Compiling " ++ f ++ "")
    verbose cfg ("     Environment variables:")
    lp <- lookupEnv "LIBRARY_PATH"
    mp <- modulePaths
    verbose cfg ("       library path = " ++ show lp)
    verbose cfg ("       module paths = " ++ show mp)
    mon <- frontend cfg f
    compile f cfg mon
    putStrLn ""

runFile :: RunConfig -> IO ()
runFile cfg = do
    let f = rInfile cfg
    putStrLn ("   Running " ++ f ++ "")
    verbose cfg ("     Environment variables:")
    mp <- modulePaths
    verbose cfg ("       module paths = " ++ show mp)
    mon <- frontend cfg f
    run f cfg mon
    putStrLn ""

frontend :: Config cfg => cfg -> FilePath -> IO Ast.Program
frontend cfg f = do
    let d = getDebug cfg
    verbose cfg ("   Lexing")
    tts <- lex f
    when d $ writeFile ".dbg.lexd" (show tts)
    verbose cfg ("   Expanding macros")
    tts' <- expandMacros f tts
    when d $ writeFile ".dbg.expanded" (show tts')
    verbose cfg ("   Parsing")
    ast <- parse f tts'
    verbose cfg ("   Typechecking")
    ann <- typecheck' f ast
    when d $ writeFile ".dbg.checked" (show ann)
    verbose cfg ("   Monomorphizing")
    let mon = monomorphize ann
    when d $ writeFile ".dbg.mono" (show mon)
    let opt = optimize mon
    when d $ writeFile ".dbg.opt" (show opt)
    pure opt

lex :: FilePath -> IO [Lexd.TokenTree]
lex f = runExceptT (Lex.lex f) >>= \case
    Left e -> putStrLn (formatLexErr e) >> abort f
    Right p -> pure p
  where
    formatLexErr e = let ss = lines e in (unlines ((head ss ++ " Error:") : tail ss))

expandMacros :: FilePath -> [Lexd.TokenTree] -> IO [Lexd.TokenTree]
expandMacros f tts = case runExcept (Macro.expandMacros tts) of
    Left e -> Err.printMacroErr e >> abort f
    Right p -> pure p

parse :: FilePath -> [Lexd.TokenTree] -> IO Parsed.Program
parse f tts = case runExcept (Parse.parse tts) of
    Left e -> Err.printParseErr e >> abort f
    Right p -> pure p

typecheck' :: FilePath -> Parsed.Program -> IO Checked.Program
typecheck' f p = case typecheck p of
    Left e -> Err.printTypeErr e >> abort f
    Right p -> pure p