[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.

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

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)
@@ -404,25 +400,6 @@ tcExtendRules lcl_rules thing_inside
 \end{code}
 
 
-%************************************************************************
-%*									*
-		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

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

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
@@ -782,33 +781,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 \end{code}
 
 
-%************************************************************************
-%*									*
-	     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

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
@@ -356,42 +352,6 @@ topStage       = Comp
 topSpliceStage = Splice (topLevel - 1)	-- Stage for the body of a top-level splice
 
 
----------------------------
--- 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
 ---------------------------
@@ -399,7 +359,7 @@ topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] }
 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}
 

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