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
|
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] (Maybe A.Type)
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
-- | @addError error@ adds @error@ to the state and returns no type to allow
-- the compilation to continue.
addError :: Error -> State CompState CompResult
addError e = do
(ev, errs) <- get
put (ev, e : errs)
return $ Right Nothing
compile :: A.Expr -> State CompState CompResult
compile x = do
case x of
(A.Module name pos) -> return $ Right Nothing
(A.BinOp _ a b) -> compileAll [a, b] -- XXX
(A.Func ident params ret body priv pos) -> do
-- current env
(ev, errs) <- get
-- updated with the function
(ev, errs) <-
return $ case addSymUniq ev (ident, ftype, pos) of
Left err -> (ev, err : errs)
Right ev -> (ev, errs)
-- with parameters
(nev, errs) <- return $ foldlEither addSymUniq (addEnv ev, errs) params
put (nev, errs)
r <- compileAll body
(_, errs) <- get
-- store updated errors and the env with the function
put (ev, errs)
return $ Right $ Just ftype
where
ftype = A.toFuncType params ret
(A.Call ident args pos) -> do
r <- compile ident
case r of
p@(Right (Just (A.FuncType params _))) ->
if length args /= length params
then addError $ Error ("invalid number of arguments in function call") pos
else return $ p
Right _ -> addError $ Error ("non callable value in function call") pos
Left r -> return $ Right Nothing
(A.Return value pos) -> case value of
Just v -> compile v
Nothing -> return $ Right Nothing
(A.Var ident pos) -> do
(ev, errs) <- get
case getSym ev ident of
Just (_, t, _) -> return $ Right $ Just t
Nothing -> addError $ Error ("undefined variable \"" ++ ident ++ "\"") pos
_ -> return $ Right Nothing
compileAll :: [A.Expr] -> State CompState CompResult
compileAll (x : xs) = do
compile x
compileAll xs
compileAll [] = do
(_, errs) <- get
case errs of
[] -> return $ Right Nothing
_ -> return $ Left errs
|
