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
|
module Compiler where
import qualified Ast as A
import Control.Monad.State
import Env
import Error
import System.Environment (getEnv, getEnvironment)
import Text.Parsec (ParseError, SourcePos)
import Text.Read (Lexeme (String))
type CompState = (Env, [Error])
type CompResult = Either [Error] ()
startState :: CompState
startState = (emptyEnv, [])
-- | @foldlEither fn init xs@ folds left @xs@ applying a function @fn@ that
-- returns either, returning accumulated right and the collected lefts as a
-- list.
foldlEither :: (accr -> b -> Either accl accr) -> (accr, [accl]) -> [b] -> (accr, [accl])
foldlEither fn init xs =
foldl
( \(r, l) x -> case fn r x of
Left e -> (r, e : l)
Right x -> (x, l)
)
init
xs
compile :: [A.Expr] -> State CompState CompResult
compile (x : xs) = do
case x of
(A.Module name pos) -> return $ Right ()
(A.BinOp _ a b) -> compile [a, b]
(A.Func ident params ret body priv pos) -> do
-- current env
(ev, errs) <- get
-- with function and parameters
(nev, nerrs) <-
return $ case addSymUniq ev (ident, A.toFuncType params ret, pos) of
Left e -> (ev, e : errs)
Right fev -> foldlEither addSymUniq (addEnv fev, errs) params
put (nev, nerrs)
r <- compile body
(_, errs) <- get
put (ev, errs)
return r
(A.Call ident args pos) -> do
id <- compile [ident]
return $ Right ()
(A.Return value pos) -> case value of
Nothing -> return $ Right ()
Just v -> compile [v]
(A.Var ident pos) -> do
(ev, errs) <- get
if existsSym ev ident
then return $ Right ()
else do
put (ev, Error ("undefined variable \"" ++ ident ++ "\"") pos : errs)
return $ Right ()
_ -> compile []
compile xs
compile [] = do
(_, errs) <- get
case errs of
[] -> return $ Right ()
_ -> return $ Left errs
|
