I'm writing a simple type-checker for a simple imperative language, and I'm currently stuck with this kind of output:
TestChecker: <<loop>>
I have alread read this question, so I know that I must be doing something wrong with a circular reference. I'm pretty sure that the problem is in the following function, which is responsible for checking a block of statements:
checkGroup :: Environ -> [Prog] -> (State, Environ, [String])
checkGroup env progs = (finalState, finalEnv, messages)
where (finalState, finalEnv, messages) = foldl checkSingleProg (Ok, empty, []) progs
checkSingleProg (s, e, msg) prog = (resS, mergeEnv e e', mess)
where (s', e', msg') = checkProg (mergeEnv' env finalEnv) prog
mess = msg ++ msg'
resS = if s == Err || s' == Err then Err else Ok
Note the:
checkProg (mergeEnv' env finalEnv) prog
Where checkProg uses as environment the merging of the environment of the father of the Group plus the environment generated by the whole Group.
(Edit: Yes I know that finalEnv is part of the output of this call to checkProg. That's the point of the question. I know it can be done, I just don't understand exactly what I'm doing wrong with this trick.)
The mergeEnv' function simply does a union between the environments (it preferes the right argument, as opposed to M.union), but keeping the left-argument's variables. It's definition is:
-- variables, functions, labels [for goto]
type Environ = (M.Map String Type, M.Map String Type, S.Set String)
mergeEnv' :: Environ -> Environ -> Environ
mergeEnv' env1 env2 = (fst' env1,
M.union (snd' env2) (snd' env1),
S.union (thr' env2) (thr' env1))
(The mergeEnv (no apos at the end) simply does all three unions.)
The Prog type is the type of statements (e.g. If, For, Group etc.)
The State type is either Ok or Err, to signal successful and unsuccessful checking.
What I'm trying to achieve is to have block-visibility for function definitions (and labels) and forward visibility for variables, without doing two different runs.
If I change:
(mergeEnv' env finalEnv)
To:
env
Everything runs "fine", but the visibility is forward only for everything.
I know that it's possible to achieve what I want in a way very similar to what I'm trying (I got the idea from my professor of Languages and Compilers), however it seems like I'm doing something wrong with the merging of the environments.
Am I doing something obviously wrong? Or should this work and the problem is probably hidden somewhere else in the type-checker?
Here's a minimal working example that demonstrates the problem. However it's still about 180 lines:
module Main where
import qualified Data.Map as M
data Prog = Group [Prog]
| Fdecl Type String [(Type, String)] Prog
| Simple Simple
deriving (Eq, Show)
data Simple = Rexp Rexp
| Vdecl Type String Rexp
| Return Rexp
deriving (Eq, Show)
data Rexp = Call String [Rexp]
| Lexp Lexp
| Const Const
deriving(Eq, Show)
data Lexp = Ident String
deriving (Eq, Show)
data Const = Integer Integer
deriving (Eq, Show)
data Type = Func Type [Type]
| Int
| Error
deriving (Eq, Show)
compatible :: Type -> Type -> Bool
compatible _ Error = True
compatible x y | x == y = True
compatible (Func ty types) (Func ty' types') = compatible ty ty' && and (zipWith compatible types types')
compatible _ _ = False
type Environ = (M.Map String Type, M.Map String Type)
empty :: Environ
empty = (M.empty, M.empty)
hasVar :: Environ -> String -> Bool
hasVar env var = M.member var $ fst env
getVarType :: Environ -> String -> Type
getVarType env var = fst env M.! var
putVar :: Environ -> String -> Type -> Environ
putVar env var ty = (M.insert var ty $ fst env, snd env)
hasFunc :: Environ -> String -> Bool
hasFunc env func = M.member func $ snd env
getFuncType :: Environ -> String -> Type
getFuncType env func = snd env M.! func
putFunc :: Environ -> String -> Type -> Environ
putFunc env func ty = (fst env, M.insert func ty $ snd env)
vars :: Environ -> M.Map String Type
vars = fst
funcs :: Environ -> M.Map String Type
funcs = snd
mergeEnv :: Environ -> Environ -> Environ
mergeEnv env1 env2 = (M.union (fst env2) (fst env1),
M.union (snd env2) (snd env1))
mergeEnv' :: Environ -> Environ -> Environ
mergeEnv' env1 env2 = (fst env1,
M.union (snd env2) (snd env1))
data State = Ok | Err
deriving (Eq, Show)
checkProg :: Environ -> Prog -> (State, Environ, [String])
checkProg env prog = case prog of
Group progs -> checkGroup env progs
Fdecl retType name params body -> checkFdecl env retType name params body
Simple simple -> checkSimple env simple
checkSimple :: Environ -> Simple -> (State, Environ, [String])
checkSimple env simple = case simple of
Rexp expr -> checkExpr expr
Vdecl typ name expr -> checkVdecl env typ name expr
Return expr -> (Ok, empty, [])
where checkExpr expr = let (t, msg) = checkRExpr env expr
in if t == Error
then (Err, empty, msg)
else (Ok, empty, msg)
checkGroup :: Environ -> [Prog] -> (State, Environ, [String])
checkGroup env progs = (finalState, finalEnv, messages)
where (finalState, finalEnv, messages) = foldl checkSingleProg (Ok, empty, []) progs
checkSingleProg (s, e, msg) prog = (resState, mergeEnv e e', message)
where (s', e', msg') = checkProg (mergeEnv' env finalEnv) prog
message = msg ++ msg'
resState = if s == Err || s' == Err then Err else Ok
checkFdecl :: Environ -> Type -> String -> [(Type, String)] -> Prog -> (State, Environ, [String])
checkFdecl env rTy name params body = (s, putFunc empty name funType, msg)
where funType = Func rTy [t | (t,_) <- params]
paramEnv = (M.fromList [(x, ty) | (ty, x) <- params], M.empty)
baseEnv = mergeEnv paramEnv (putFunc env name funType)
(s, e', msg) = checkProg baseEnv body
checkVdecl :: Environ -> Type -> String -> Rexp -> (State, Environ, [String])
checkVdecl env ty name expr = if t == Error
then (Err, empty, msg)
else if compatible t ty
then (Ok, putVar empty name ty, msg)
else (Err, empty, msg ++ errMsg)
where (t, msg) = checkRExpr env expr
errMsg = ["Incompatible assignment of type: " ++ show t ++ " to a variable of type: " ++ show ty]
checkRExpr env expr = case expr of
Const _-> (Int, [])
Lexp lexp -> checkLExpr env lexp
Call name params -> checkCall env name params
checkLExpr env lexp = if env `hasVar` name
then (getVarType env name, [])
else (Error, ["Undefined identifier: " ++ name])
where (Ident name) = lexp
checkCall env name params = if not $ env `hasFunc` name
then (Error, ["Undefined function: " ++ name])
else let (Func retTy paramsTy) = getFuncType env name
in if length params /= length paramsTy
then (Error, ["wrong number of arguments."])
else if and $ zipWith checkParam paramsTy params
then (retTy, [])
else (Error, ["Wrong type for argument."])
where checkParam typ param = let (t, _) = checkRExpr env param
in compatible t typ
{-
def f() -> int:
return g()
def g() -> int:
return 1
f()
-}
testProg = Group [Fdecl Int "f" [] $ Group [Simple $ Return $ Call "g" []],
Fdecl Int "g" [] $ Group [Simple $ Return $ Const $ Integer 1],
Simple $ Rexp $ Call "f" []]
main = do
let (s,e,msg) = checkProg empty testProg
if s == Ok
then putStrLn "Correct!"
else putStrLn "Error!"
putStrLn $ concatMap (++ "\n") msg
