Commit 00007e64 authored by ross's avatar ross
Browse files

[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.
parent 0600a65d
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment