- do e_venv' <- foldM extendVenv e_venv e_vts
- l_venv' <- foldM extendVenv l_venv l_vts
- let env' = (tcenv,tsenv,tvenv,cenv,e_venv',l_venv')
- mapM_ (\ (vdef@(Vdef ((m,_),t,e))) ->
- do mn <- getMname
- requireModulesEq m mn "value definition" vdef True
- k <- checkTy (tcenv,tvenv) t
- require (k `eqKind` Klifted) ("unlifted kind in:\n" ++ show vdef)
- t' <- checkExp env' e
- requireM (equalTy tsenv t t')
- ("declared type doesn't match expression type in:\n" ++ show vdef ++ "\n" ++
- "declared type: " ++ show t ++ "\n" ++
- "expression type: " ++ show t')) vdefs
- return (e_venv',l_venv')
- where e_vts = [ (v,t) | Vdef ((Just _,v),t,_) <- vdefs ]
- l_vts = [ (v,t) | Vdef ((Nothing,v),t,_) <- vdefs]
- Nonrec (vdef@(Vdef ((m,v),t,e))) ->
- do mn <- getMname
- -- TODO: document this weirdness
- let isZcMain = vdefIsMainWrapper mn m
- unless isZcMain $
- requireModulesEq m mn "value definition" vdef True
- k <- checkTy (tcenv,tvenv) t
- require (not (k `eqKind` Kopen)) ("open kind in:\n" ++ show vdef)
- require ((not top_level) || (not (k `eqKind` Kunlifted)))
- ("top-level unlifted kind in:\n" ++ show vdef)
- t' <- checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv) e
- requireM (equalTy tsenv t t')
- ("declared type doesn't match expression type in:\n"
- ++ show vdef ++ "\n" ++
- "declared type: " ++ show t ++ "\n" ++
- "expression type: " ++ show t')
- if isNothing m then
- do l_venv' <- extendVenv l_venv (v,t)
- return (e_venv,l_venv')
- else
- -- awful, but avoids name shadowing --
- -- otherwise we'd have two bindings for "main"
- do e_venv' <- if isZcMain
- then return e_venv
- else extendVenv e_venv (v,t)
- return (e_venv',l_venv)
+ do (e_venv', l_venv') <- makeEnv mn vdefs
+ let env' = (tcenv,tvenv,cenv,e_venv',l_venv')
+ mapM_ (checkVdef (\ vdef k -> require (k `eqKind` Klifted)
+ ("unlifted kind in:\n" ++ show vdef)) env')
+ vdefs
+ return (e_venv', l_venv')
+ Nonrec vdef ->
+ do let env' = (tcenv, tvenv, cenv, e_venv, l_venv)
+ checkVdef (\ vdef k -> do
+ require (not (k `eqKind` Kopen)) ("open kind in:\n" ++ show vdef)
+ require ((not top_level) || (not (k `eqKind` Kunlifted)))
+ ("top-level unlifted kind in:\n" ++ show vdef)) env' vdef
+ makeEnv mn [vdef]
+
+ where makeEnv mn vdefs = do
+ ev <- foldM extendVenv e_venv e_vts
+ lv <- foldM extendVenv l_venv l_vts
+ return (ev, lv)
+ where e_vts = [ (v,t) | Vdef ((Just m,v),t,_) <- vdefs,
+ not (vdefIsMainWrapper mn (Just m))]
+ l_vts = [ (v,t) | Vdef ((Nothing,v),t,_) <- vdefs]
+ checkVdef checkKind env (vdef@(Vdef ((m,_),t,e))) = do
+ mn <- getMname
+ let isZcMain = vdefIsMainWrapper mn m
+ unless isZcMain $
+ requireModulesEq m mn "value definition" vdef True
+ k <- checkTy (tcenv,tvenv) t
+ checkKind vdef k
+ t' <- checkExp env e
+ require (t == t')
+ ("declared type doesn't match expression type in:\n"
+ ++ show vdef ++ "\n" ++
+ "declared type: " ++ show t ++ "\n" ++
+ "expression type: " ++ show t')