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
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
module Micro.Compiler
( version,
compile,
compileToAst,
)
where
import Control.Arrow (ArrowChoice (left))
import Control.Monad.State
import Data.Foldable (traverse_)
import Data.Maybe (isNothing, mapMaybe)
import Micro.Asm.Sdcc (generate)
import qualified Micro.Ast as A
import Micro.Env
import Micro.Error
import Text.Parsec (SourcePos)
version :: String
version = "0.1.0"
data CompState = CompState
{ stEnv :: Env,
stErr :: [Error]
}
deriving (Show)
startState :: CompState
startState = CompState 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 =
foldl
( \(r, l) x -> case fn r x of
Left e -> (r, e : l)
Right x -> (x, l)
)
-- | @addError error@ adds @error@ to the state and returns no type to allow
-- the compilation to continue.
addError :: Error -> State CompState (Maybe A.Type)
addError e = do
modify $ \st -> st {stErr = e : stErr st}
pure 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"
| null params = pure Nothing
| otherwise = do
-- resolve all args types
targs <- traverse compileOne args
case sequence targs of
Just t
-- after resolution, we could have less "rights"
| length t /= length params -> pure Nothing
-- compare types
| all (uncurry (==)) $ zip t params ->
pure Nothing -- all good!
| otherwise -> 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
pure Nothing
-- | @showMaybeType t@ is a helper to show nicely a @Maybe A.Type@.
showMaybeType :: Maybe A.Type -> String
showMaybeType Nothing = "()"
showMaybeType (Just t) = show t
-- | @typecheck expected found pos@ compares expected and found, returning either expected of adding an type error to the state.
typecheck :: Maybe A.Type -> Maybe A.Type -> SourcePos -> State CompState (Maybe A.Type)
typecheck expected found pos
| expected == found = pure expected
| otherwise = addError $ Error TypeError ("type mismatch\n found: " ++ showMaybeType found ++ "\n expected: " ++ showMaybeType expected) pos
-- built-in types
types :: [String]
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 && maybe False definedType r
verifyFuncType :: String -> [A.FuncParam] -> Maybe A.Type -> SourcePos -> [Error]
verifyFuncType ident params ret pos = do
mapMaybe
( \(_, t, _, pos) ->
if not (definedType t)
then Just $ Error UndefinedType ("undefined type in declaration of \"" ++ ident ++ "\"") pos
else Nothing
)
params
++ [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos | not (maybe True definedType ret)]
compileOne :: A.Expr -> State CompState (Maybe A.Type)
compileOne x = do
case x of
(A.Module _ _) -> pure Nothing
(A.Num _ _) -> pure $ Just $ A.Type "u8" -- TODO: placeholder
(A.Bool' _ _) -> pure $ Just $ A.Type "bool"
(A.BinOp _ pos (A.Bool' _ _) (A.Bool' _ _)) ->
-- for now this is true
addError $ Error InvalidOperation "invalid operation for type bool" pos
(A.BinOp op pos a b) -> do
ta <- compileOne a
tb <- compileOne b
case op of
A.Assign -> case a of
(A.Variable _ _) -> typecheck ta tb pos
_ -> addError $ Error InvalidTarget "invalid assignment target" pos
_ -> typecheck ta tb pos
(A.Func ident params ret body priv anon pos) -> do
-- current env
st <- get
-- check for undefined types
(ev, errs) <- return (stEnv st, verifyFuncType ident params ret pos ++ stErr st)
-- updated with the function
(ev, errs) <-
return $ case addSymUniq ev (Sym ident ftype priv False pos) of
Left err -> (ev, err : errs)
Right ev -> (ev, errs)
-- lambdas can only access local variables (closures aren't supported)
let fev = if anon then emptyEnv else ev
-- with parameters
(nev, errs) <- return $ foldlEither addSymUniq (addEnv fev, errs) $ map (toSym True) params
-- helper for return
nev <- return $ addSym nev $ Sym "$fn$" ftype True True pos
put st {stEnv = nev, stErr = errs}
_ <- compileAll body
-- store updated errors and the env with the function
modify $ \st -> st {stEnv = ev}
pure Nothing
where
ftype = A.toFuncType params ret
(A.Call ident args pos) -> do
r <- compileOne ident
case r of
Just (A.FuncType params rtyp) -> do
e <- typecheckCall args params
case e of
Just err -> addError $ Error TypeError err pos
Nothing -> pure rtyp
_ -> addError $ Error NonCallable "non callable value in function call" pos
(A.Var ident typ val priv local pos) -> do
st <- get
(ev, errs) <- return $ foldlEither addSymUniq (stEnv st, stErr st) [Sym ident typ priv local pos]
errs <-
return $
if not (definedType typ)
then Error UndefinedType ("undefined type in declaration \"" ++ ident ++ "\"") pos : errs
else errs
put st {stEnv = ev, stErr = errs}
t <- compileOne val
typecheck (Just typ) t pos
(A.Return value pos) -> do
st <- get
case getSyml (stEnv st) "$fn$" of
Just Sym {symType = A.FuncType _ rtyp} -> do
case value of
Nothing ->
if isNothing rtyp
then pure Nothing
else addError $ Error TypeError ("invalid return value\n found: ()\n expected: " ++ showMaybeType rtyp) pos
Just v -> do
r <- compileOne v
typecheck rtyp r pos
_ -> addError $ Error UnexpectedReturn "return without function call" pos
(A.Variable ident pos) -> do
st <- get
case getSym (stEnv st) ident of
Just Sym {symType = t} -> pure $ Just t
Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos
foldConstant :: A.Expr -> Either Error A.Expr
foldConstant x =
case x of
-- FIXME: overflow?
(A.BinOp A.Plus pos (A.Num a _) (A.Num b _)) -> Right $ A.Num (a + b) pos
(A.BinOp A.Minus pos (A.Num a _) (A.Num b _)) -> Right $ A.Num (a - b) pos
(A.BinOp A.Mul pos (A.Num a _) (A.Num b _)) -> Right $ A.Num (a * b) pos
(A.BinOp A.Mul pos _ (A.Num 0 _)) -> Right $ A.Num 0 pos
(A.BinOp A.Mul pos (A.Num 0 _) _) -> Right $ A.Num 0 pos
(A.BinOp A.Div pos _ (A.Num 0 _)) -> Left $ Error InvalidOperation "division by zero" pos
(A.BinOp A.Div pos (A.Num a _) (A.Num b _)) -> Right $ A.Num (a `div` b) pos
(A.BinOp op pos a b) -> do
fa <- foldConstant a
fb <- foldConstant b
let newOp = A.BinOp op pos fa fb
if newOp /= x then foldConstant newOp else Right newOp
(A.Func ident params ret body priv anon pos) -> do
fbody <- traverse foldConstant body
Right $ A.Func ident params ret fbody priv anon pos
(A.Call ident args pos) -> do
fid <- foldConstant ident
fargs <- traverse foldConstant args
Right $ A.Call fid fargs pos
(A.Var ident typ val priv local pos) -> do
fv <- foldConstant val
Right $ A.Var ident typ fv priv local pos
(A.Return value pos) -> do
fv <- traverse foldConstant value
Right $ A.Return fv pos
_ -> Right x
compileAll :: [A.Expr] -> State CompState (Either [Error] SymMap)
compileAll ast = do
traverse_ compileOne ast
st <- get
let (Env sym _) = stEnv st
let errs = stErr st
case errs of
[] -> pure $ Right sym
_ -> return $ Left errs
compileToAst :: [A.Expr] -> Either [Error] [A.Expr]
compileToAst ast = do
_ <- evalState (compileAll ast) startState
left (: []) $ traverse foldConstant ast
compile :: [A.Expr] -> Either [Error] String
compile ast = do
_ <- evalState (compileAll ast) startState
fast <- left (: []) $ traverse foldConstant ast
return $ generate version fast
|
