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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
module Compiler where
import qualified Ast as A
import Control.Monad.State
import Data.Either (rights)
import Data.Maybe (catMaybes, fromMaybe)
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
-- | @typecheckCall args params@ resolves @args@ and compares it with @params@,
-- returning a string describing an error or Nothing in case of type match.
typecheckCall :: [A.Expr] -> [A.Type] -> State CompState (Maybe String)
typecheckCall args params
| length args /= length params = return $ Just "invalid number of arguments in function call"
| length params == 0 = return $ Nothing
| otherwise = do
-- resolve all args types
targs <- fmap rights $ traverse compile args
case sequence targs of
Just t ->
if length t /= length params
then -- there was an error in one argument
return $ Nothing
else
if all (\(a, b) -> a == b) $ zip t params -- compare types
then return $ Nothing -- all good!
else return $ Just ("type mismatch in function call\n found: " ++ A.showList t ++ "\n expected: " ++ A.showList params)
Nothing ->
-- there was an error in on argument
return $ Nothing
showMaybet :: Maybe A.Type -> String
showMaybet Nothing = "()"
showMaybet (Just t) = show t
-- | @typecheckReturn value fret@ resolves @value@ and compares it with @fret@,
-- returning a string decribing an error or Nothing in case of a type match.
typecheckReturn :: Maybe A.Expr -> Maybe A.Type -> State CompState (Maybe String)
typecheckReturn Nothing Nothing = return $ Nothing
typecheckReturn Nothing fret = return $ Just $ "invalid return value\n found: ()\n expected: " ++ showMaybet fret
typecheckReturn (Just value) fret = do
r <- compile value
case r of
Right r ->
if r == fret
then return $ Nothing
else return $ Just $ "invalid return value\n found: " ++ showMaybet r ++ "\n expected: " ++ showMaybet fret
Left _ -> return $ Nothing -- error resolving return value
-- built-in types
types = ["bool", "u8", "s8", "u16", "s16"]
definedType :: A.Type -> Bool
definedType (A.Type t) = t `elem` types
definedType (A.FuncType ts r) =
all definedType ts && fromMaybe False (fmap definedType r)
verifyFuncType :: String -> [A.FuncParam] -> Maybe A.Type -> SourcePos -> [Error]
verifyFuncType ident params ret pos = do
( catMaybes $
map
( \(id, t, _, pos) ->
if not (definedType t)
then Just $ Error UndefinedType ("undefined type in function declaration \"" ++ id ++ "\"") pos
else Nothing
)
params
)
++ if not (fromMaybe True (fmap definedType ret))
then [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos]
else []
compile :: A.Expr -> State CompState CompResult
compile x = do
case x of
(A.Module name pos) -> return $ Right Nothing
(A.Num _ _) -> return $ Right $ Just $ A.Type "u8" -- TODO: placeholder
(A.Bool' _ _) -> return $ Right $ Just $ A.Type "bool"
(A.BinOp _ a b) -> do
l <- compile a
r <- compile b
return $ l -- TODO: placeholder
(A.Func ident params ret body priv anon pos) -> do
-- current env
(ev, errs) <- get
-- check for undefined types
(ev, errs) <- return $ (ev, (verifyFuncType ident params ret pos) ++ errs)
-- updated with the function
(ev, errs) <-
return $ case addSymUniq ev (ident, ftype, priv, pos) of
Left err -> (ev, err : errs)
Right ev -> (ev, errs)
-- lambdas can only access local variables (closures aren't supported)
fev <- return $ if anon then emptyEnv else ev
-- with parameters
(nev, errs) <- return $ foldlEither addSymUniq (addEnv fev, errs) params
-- helper for return
nev <- return $ addSym nev ("$fn$", ftype, True, pos)
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
Right (Just (A.FuncType params rtyp)) -> do
r <- typecheckCall args params
case r of
Just err -> addError $ Error TypeError err pos
Nothing -> return $ Right rtyp
Right _ -> addError $ Error NonCallable "non callable value in function call" pos
_ -> return $ Right Nothing
(A.Var ident typ val priv pos) -> do
(ev, errs) <- get
(ev, errs) <- return $ foldlEither addSymUniq (ev, errs) [(ident, typ, priv, pos)]
errs <-
return $
if not (definedType typ)
then Error UndefinedType ("undefined type in variable declaration \"" ++ ident ++ "\"") pos : errs
else errs
-- type-check value
vt <- compile val
errs <- case vt of
Right (Just t) ->
if t == typ
then return $ errs
else return $ (Error TypeError ("value type mismatch\n found: " ++ show t ++ "\n expected: " ++ show typ) pos) : errs
_ -> do
(_, errs) <- get -- error resolving value
return $ errs
put (ev, errs)
return $ Right $ Just typ
(A.Return value pos) -> do
(ev, errs) <- get
case getSyml ev "$fn$" of
Nothing -> addError $ Error UnexpectedReturn "return without function call" pos
Just (_, A.FuncType _ rtyp, _, _) -> do
r <- typecheckReturn value rtyp
case r of
Just err -> addError $ Error TypeError err pos
Nothing -> return $ Right rtyp
(A.Variable ident pos) -> do
(ev, errs) <- get
case getSym ev ident of
Just (_, t, _, _) -> return $ Right $ Just t
Nothing -> addError $ Error Undefined ("undefined variable \"" ++ ident ++ "\"") pos
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
|
