\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) ->
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)
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
%* *
%************************************************************************
-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
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
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
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
ThStage(..), topStage, topSpliceStage,
ThLevel, impLevel, topLevel,
+ -- Arrows
+ newArrowScope, escapeArrowScope,
+
-- Insts
Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc,
instLocSrcLoc, instLocSrcSpan,
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
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
projects / ghc-hetmet.git / commitdiff