From 00007e64fd17385867ab6b835a2ef77575e86229 Mon Sep 17 00:00:00 2001 From: ross Date: Wed, 4 May 2005 10:28:08 +0000 Subject: [PATCH] [project @ 2005-05-04 10:28:07 by ross] Another go at the handling of -< in arrow notation, continuing and fixing the changes in http://www.haskell.org/pipermail/cvs-all/2005-April/040391.html Now do the same thing in the renamer as we do in the type checker, i.e. return to the environment of the proc when considering the left argument of -<. This is much simpler than the old proc_level stuff, and matches the type rules more clearly. But there is a change in error messages. For the input f :: Int -> Int f = proc x -> (+x) -< 1 GHC 6.4 says test.hs:6: Command-bound variable `x' is not in scope here Reason: it is used in the left argument of (-<) In the second argument of `(+)', namely `x' In the command: (+ x) -< 1 In the definition of `f': f = proc x -> (+ x) -< 1 but now we just get the blunt test.hs:6:16: Not in scope: `x' The beauty is all on the inside. Similarly leakage of existential type variables (arrow1) is detected, but the error message isn't very helpful. --- ghc/compiler/rename/RnExpr.lhs | 18 ++++++++++----- ghc/compiler/typecheck/TcArrows.lhs | 40 +++++++++------------------------- ghc/compiler/typecheck/TcRnMonad.lhs | 1 + ghc/compiler/typecheck/TcRnTypes.lhs | 38 ++++++++++++++++++++++++++++++++ 4 files changed, 61 insertions(+), 36 deletions(-) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 624cc4b..c33cbe0 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -352,19 +352,25 @@ rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` \begin{code} rnExpr (HsProc pat body) - = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] -> + = newArrowScope $ + rnPatsAndThen ProcExpr True [pat] $ \ [pat'] -> rnCmdTop body `thenM` \ (body',fvBody) -> returnM (HsProc pat' body', fvBody) rnExpr (HsArrApp arrow arg _ ho rtl) - = rnLExpr arrow `thenM` \ (arrow',fvArrow) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> + = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> returnM (HsArrApp arrow' arg' placeHolderType ho rtl, fvArrow `plusFV` fvArg) + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc -- infix form rnExpr (HsArrForm op (Just _) [arg1, arg2]) - = rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) -> + = escapeArrowScope (rnLExpr op) + `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) -> rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> @@ -377,8 +383,8 @@ rnExpr (HsArrForm op (Just _) [arg1, arg2]) fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) rnExpr (HsArrForm op fixity cmds) - = rnLExpr op `thenM` \ (op',fvOp) -> - rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> + = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> + rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 08682ae..b02eb2b 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -50,12 +50,12 @@ tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr tcProc pat cmd exp_ty -- gaw 2004 FIX? - = do { arr_ty <- newTyFlexiVarTy arrowTyConKind + = newArrowScope $ do + { arr_ty <- newTyFlexiVarTy arrowTyConKind ; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind ; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty]) - ; proc_env <- getEnv - ; let cmd_env = CmdEnv { cmd_arr = arr_ty, cmd_proc_env = proc_env } + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; ([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 @@ -72,36 +72,16 @@ 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, -- arrow type constructor, of kind *->*->* - cmd_proc_env :: Env TcGblEnv TcLclEnv -- environment of the proc + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* } 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 @@ -165,19 +145,19 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) do { arg_ty <- newTyFlexiVarTy openTypeKind ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty - ; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty) + ; fun' <- select_arrow_scope (tcCheckRho fun fun_ty) ; arg' <- tcCheckRho arg arg_ty ; return (HsArrApp fun' arg' fun_ty ho_app lr) } where - -- Before type-checking f, remove the "arrow binders" from the - -- environment in the (-<) case. + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. -- Local bindings, inside the enclosing proc, are not in scope -- inside f. In the higher-order case (-<<), they are. - pop_arrow_binders tc = case ho_app of + select_arrow_scope tc = case ho_app of HsHigherOrderApp -> tc - HsFirstOrderApp -> popArrowBinders env tc + HsFirstOrderApp -> escapeArrowScope tc ------------------------------------------- -- Command application @@ -273,7 +253,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) e_res_ty -- Check expr - ; (expr', lie) <- popArrowBinders env (getLIE (tcCheckRho expr e_ty)) + ; (expr', lie) <- escapeArrowScope (getLIE (tcCheckRho expr e_ty)) ; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie -- Check that the polymorphic variable hasn't been unified with anything diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 41e1133..71a20d8 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -109,6 +109,7 @@ initTc hsc_env hsc_src mod do_this tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, + tcl_arrow_ctxt = panic "initTc:arrow", -- only used inside proc tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 3d1329f..ece741f 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -26,6 +26,9 @@ module TcRnTypes( ThStage(..), topStage, topSpliceStage, ThLevel, impLevel, topLevel, + -- Arrows + newArrowScope, escapeArrowScope, + -- Insts Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc, instLocSrcSpan, @@ -291,6 +294,7 @@ 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 @@ -367,6 +371,40 @@ topStage, topSpliceStage :: ThStage topStage = Comp topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice +--------------------------- +-- Arrow-notation context +--------------------------- + +{- +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 (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). +-} + +newtype ArrowCtxt = ArrowCtxt { arr_proc_env :: Env TcGblEnv TcLclEnv } + +-- Record the current environment (outside a proc) +newArrowScope :: TcM a -> TcM a +newArrowScope + = updEnv $ \env -> + env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } } + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope = updEnv (arr_proc_env . tcl_arrow_ctxt . env_lcl) --------------------------- -- TcTyThing -- 1.7.10.4