在<loop>类型检查器中实现块可见性时获取<>

Question

我正在为一种简单的命令式语言编写一个简单的类型检查器，我目前坚持这种输出：

TestChecker: <<loop>>

我已经读过这个问题，所以我知道我一定是用循环引用做错了什么。我很确定问题出在以下函数中，该函数负责检查语句块：

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

请注意：

checkProg (mergeEnv' env finalEnv) prog

其中checkProg将Group之父的环境与整个Group产生的环境合并为环境。

(编辑：是的，我知道finalEnv是这个checkProg调用输出的一部分。这就是问题的重点。我知道这是可以做到的，我只是不明白我用这个技巧做错了什么。

mergeEnv'函数只是在环境之间做一个联合(它更喜欢右参数，而不是M.union)，但保留左参数的变量。它的定义是：

-- 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))

(mergeEnv(最后没有apos)只是做所有三个工会。

Prog类型是语句的类型(例如If、For、Group等)State类型为Ok或Err，表示检查成功和失败。

我试图实现的是函数定义(和标签)的块可见性和变量的前向可见性，而无需进行两次不同的运行。

如果我更改：

(mergeEnv' env finalEnv)

自：

env

一切都运行"良好"，但可见性仅适用于所有内容。

我知道有可能以与我正在尝试的方式非常相似的方式实现我想要的东西(我从我的语言和编译器教授那里得到了这个想法)，但是似乎我在合并环境方面做错了什么。

我做错了什么吗？或者这应该工作并且问题可能隐藏在类型检查器中的其他地方？

---

下面是一个演示问题的最小工作示例。但是它仍然是大约 180 行：

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

Answer 1

你用foldl来定义finalEnv，你正在通过checkProg来定义foldl，根据finalEnv所以你的算法似乎是错误的。