From: ross Date: Sat, 16 Apr 2005 16:05:53 +0000 (+0000) Subject: [project @ 2005-04-16 16:05:52 by ross] X-Git-Tag: Initial_conversion_from_CVS_complete~730 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=872f7e822cb83692afa808509b4f2a6b4343fb2c [project @ 2005-04-16 16:05:52 by ross] Rejig handling of environments in arrow notation: instead of the proc_level stuff, we just record the environment of the proc, and use that on the left side of -< and the head of (|...|). This also makes the arrow1 test yield a compile error, as it should, but the error message is uninformative. --- diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 7829785..08682ae 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -54,9 +54,9 @@ tcProc pat cmd exp_ty ; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind ; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty]) - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; ([pat'], cmd') <- incProcLevel $ - tcMatchPats [pat] [Check arg_ty] (Check res_ty) $ + ; proc_env <- getEnv + ; let cmd_env = CmdEnv { cmd_arr = arr_ty, cmd_proc_env = proc_env } + ; ([pat'], cmd') <- tcMatchPats [pat] [Check arg_ty] (Check res_ty) $ tcCmdTop cmd_env cmd ([], res_ty) -- The False says don't do GADT type refinement -- This is a conservative choice, but I'm not sure of the consequences @@ -72,13 +72,36 @@ tcProc pat cmd exp_ty %* * %************************************************************************ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. We implement this by +recording the environment when passing a proc, and returning to that +(using popArrowBinders) on the left of -< and the head of (|..|). + \begin{code} type CmdStack = [TcTauType] -data CmdEnv = CmdEnv { cmd_arr :: TcType } -- The arrow type constructor, of kind *->*->* +data CmdEnv + = CmdEnv { + cmd_arr :: TcType, -- arrow type constructor, of kind *->*->* + cmd_proc_env :: Env TcGblEnv TcLclEnv -- environment of the proc + } mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] +popArrowBinders :: CmdEnv -> TcM a -> TcM a +popArrowBinders env tc = setEnv (cmd_proc_env env) tc + --------------------------------------- tcCmdTop :: CmdEnv -> LHsCmdTop Name @@ -154,7 +177,7 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) -- inside f. In the higher-order case (-<<), they are. pop_arrow_binders tc = case ho_app of HsHigherOrderApp -> tc - HsFirstOrderApp -> popArrowBinders tc + HsFirstOrderApp -> popArrowBinders env tc ------------------------------------------- -- Command application @@ -250,7 +273,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) e_res_ty -- Check expr - ; (expr', lie) <- popArrowBinders (getLIE (tcCheckRho expr e_ty)) + ; (expr', lie) <- popArrowBinders env (getLIE (tcCheckRho expr e_ty)) ; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie -- Check that the polymorphic variable hasn't been unified with anything @@ -289,7 +312,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) (badFormFun i tup_ty') - ; tcCmdTop (CmdEnv { cmd_arr = b }) cmd (arg_tys, s) } + ; tcCmdTop (env { cmd_arr = b }) cmd (arg_tys, s) } unscramble :: TcType -> (TcType, [TcType]) -- unscramble ((w,s1) .. sn) = (w, [s1..sn]) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 9fd20a0..9b2ce42 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -36,9 +36,6 @@ module TcEnv( checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, topIdLvl, - -- Arrow stuff - checkProcLevel, - -- New Ids newLocalName, newDFunName ) where @@ -210,7 +207,7 @@ tcLookupId :: Name -> TcM Id tcLookupId name = tcLookup name `thenM` \ thing -> case thing of - ATcId tc_id _ _ -> returnM tc_id + ATcId tc_id _ -> returnM tc_id AGlobal (AnId id) -> returnM id other -> pprPanic "tcLookupId" (ppr name) @@ -223,8 +220,8 @@ tcLookupLocalIds ns where lookup lenv lvl name = case lookupNameEnv lenv name of - Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id - other -> pprPanic "tcLookupLocalIds" (ppr name) + Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id + other -> pprPanic "tcLookupLocalIds" (ppr name) lclEnvElts :: TcLclEnv -> [TcTyThing] lclEnvElts env = nameEnvElts (tcl_env env) @@ -291,8 +288,7 @@ tcExtendIdEnv2 names_w_ids thing_inside let extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids] th_lvl = thLevel (tcl_th_ctxt env) - proc_lvl = proc_level (tcl_arrow_ctxt env) - extra_env = [(name, ATcId id th_lvl proc_lvl) | (name,id) <- names_w_ids] + extra_env = [(name, ATcId id th_lvl) | (name,id) <- names_w_ids] le' = extendNameEnvList (tcl_env env) extra_env rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map fst names_w_ids) in @@ -326,7 +322,7 @@ findGlobals tvs tidy_env ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty) ----------------------- -find_thing ignore_it tidy_env (ATcId id _ _) +find_thing ignore_it tidy_env (ATcId id _) = zonkTcType (idType id) `thenM` \ id_ty -> if ignore_it id_ty then returnM (tidy_env, Nothing) @@ -406,25 +402,6 @@ tcExtendRules lcl_rules thing_inside %************************************************************************ %* * - Arrow notation proc levels -%* * -%************************************************************************ - -\begin{code} -checkProcLevel :: TcId -> ProcLevel -> TcM () -checkProcLevel id id_lvl - = do { banned <- getBannedProcLevels - ; checkTc (not (id_lvl `elem` banned)) - (procLevelErr id id_lvl) } - -procLevelErr id id_lvl - = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here")) - 4 (ptext SLIT("Reason: it is used in the left argument of (-<)")) -\end{code} - - -%************************************************************************ -%* * Meta level %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6d441b2..3708436 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -32,7 +32,7 @@ import BasicTypes ( isMarkedStrict ) import Inst ( tcOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookup, tcLookupId, checkProcLevel, +import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupGlobalId ) import TcArrows ( tcProc ) @@ -787,9 +787,7 @@ tcId orig id_name -- Look up the Id and instantiate its type -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment - ; ATcId id th_level proc_level - -> do { checkProcLevel id proc_level - ; tc_local_id id th_level } + ; ATcId id th_level -> tc_local_id id th_level ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 6160177..6ff9043 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -106,7 +106,6 @@ initTc hsc_env hsc_src mod do_this tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, - tcl_arrow_ctxt = topArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE @@ -784,33 +783,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ %* * - Arrow context -%* * -%************************************************************************ - -\begin{code} -popArrowBinders :: TcM a -> TcM a -- Move to the left of a (-<); see comments in TcRnTypes -popArrowBinders - = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env) }) - where - pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned}) - = ASSERT( not (curr_lvl `elem` banned) ) - ArrCtxt {proc_level = curr_lvl + 1, proc_banned = curr_lvl : banned} - -getBannedProcLevels :: TcM [ProcLevel] -getBannedProcLevels - = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) } - -incProcLevel :: TcM a -> TcM a -incProcLevel - = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) }) - where - inc ctxt = ctxt { proc_level = proc_level ctxt + 1 } -\end{code} - - -%************************************************************************ -%* * Stuff for the renamer's local env %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index f9f9275..4bd633b 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -26,9 +26,6 @@ module TcRnTypes( ThStage(..), topStage, topSpliceStage, ThLevel, impLevel, topLevel, - -- Arrows - ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel, - -- Insts Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc, instLocSrcSpan, @@ -278,7 +275,6 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef Messages, -- Place to accumulate errors tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during @@ -357,49 +353,13 @@ topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level spli --------------------------- --- Arrow-notation stages ---------------------------- - --- In arrow notation, a variable bound by a proc (or enclosed let/kappa) --- is not in scope to the left of an arrow tail (-<) or the head of (|..|). --- For example --- --- proc x -> (e1 -< e2) --- --- Here, x is not in scope in e1, but it is in scope in e2. This can get --- a bit complicated: --- --- let x = 3 in --- proc y -> (proc z -> e1) -< e2 --- --- Here, x and z are in scope in e1, but y is not. Here's how we track this: --- a) Assign an "proc level" to each proc, being the number of --- lexically-enclosing procs + 1. --- b) Assign to each local variable the proc-level of its lexically --- enclosing proc. --- c) Keep a list of out-of-scope procs. When moving to the left of --- an arrow-tail, add the proc-level of the immediately enclosing --- proc to the list, and increment the proc-level so that variables --- bound inside the expression are in scope. --- d) When looking up a variable, complain if its proc-level is in --- the banned list - -type ProcLevel = Int -- Always >= 0 -topProcLevel = 0 -- Not inside any proc - -data ArrowCtxt = ArrCtxt { proc_level :: ProcLevel, -- Current level - proc_banned :: [ProcLevel] } -- Out of scope proc-levels - -topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] } - ---------------------------- -- TcTyThing --------------------------- data TcTyThing = AGlobal TyThing -- Used only in the return type of a lookup - | ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked + | ATcId TcId ThLevel -- Ids defined in this module; may not be fully zonked | ATyVar Name TcType -- Type variables; tv -> type. It can't just be a TyVar -- that is mutated to point to the type it is bound to, @@ -412,15 +372,15 @@ data TcTyThing instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = ppr g - ppr (ATcId g tl pl) = text "Identifier" <> - ifPprDebug (brackets (ppr g <> comma <> ppr tl <> comma <> ppr pl)) + ppr (ATcId g tl) = text "Identifier" <> + ifPprDebug (brackets (ppr g <> comma <> ppr tl)) ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty ppr (AThing k) = text "AThing" <+> ppr k pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing pprTcTyThingCategory (ATyVar _ _) = ptext SLIT("Type variable") -pprTcTyThingCategory (ATcId _ _ _) = ptext SLIT("Local identifier") +pprTcTyThingCategory (ATcId _ _) = ptext SLIT("Local identifier") pprTcTyThingCategory (AThing _) = ptext SLIT("Kinded thing") \end{code} diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 376b3ea..d872de5 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -544,7 +544,7 @@ reifyThing (AGlobal (ADataCon dc)) ; fix <- reifyFixity name ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) } -reifyThing (ATcId id _ _) +reifyThing (ATcId id _) = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even -- though it may be incomplete ; ty2 <- reifyType ty1