Commit f50d62bb authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Fix the scope-nesting for arrows

Previously we were capturing the *entire environment* when moving under
a 'proc', for the newArrowScope/escapeArrowScope thing.  But that a blunderbuss,
and in any case isn't right (the untouchable-type-varaible invariant gets
invalidated).

So I fixed it to be much more refined: just the LocalRdrEnv and constraints are
captured.

I think this is right; but if not we should just add more fields to ArrowCtxt,
not return to the blunderbuss.

This patch fixes the ASSERT failure in Trac #5267
parent 75c211ec
......@@ -197,8 +197,6 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
do { arg_ty <- newFlexiTyVarTy openTypeKind
; let fun_ty = mkCmdArrTy env arg_ty res_ty
; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
-- ToDo: There should be no need for the escapeArrowScope stuff
-- See Note [Escaping the arrow scope] in TcRnTypes
; arg' <- tcMonoExpr arg arg_ty
......@@ -208,6 +206,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
-- proc for the (-<) case.
-- Local bindings, inside the enclosing proc, are not in scope
-- inside f. In the higher-order case (-<<), they are.
-- See Note [Escaping the arrow scope] in TcRnTypes
select_arrow_scope tc = case ho_app of
HsHigherOrderApp -> tc
HsFirstOrderApp -> escapeArrowScope tc
......
......@@ -377,6 +377,28 @@ getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
; return (eps, hsc_HPT env) }
{-
************************************************************************
* *
Arrow scopes
* *
************************************************************************
-}
newArrowScope :: TcM a -> TcM a
newArrowScope
= updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
= updLclEnv $ \ env ->
case tcl_arrow_ctxt env of
NoArrowCtxt -> env
ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
, tcl_lie = lie
, tcl_rdr = rdr_env }
{-
************************************************************************
* *
......
......@@ -45,7 +45,7 @@ module TcRnTypes(
ThLevel, impLevel, outerLevel, thLevel,
-- Arrows
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
ArrowCtxt(..),
-- Canonical constraints
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
......@@ -603,7 +603,7 @@ data TcLclEnv -- Changes as we move inside an expression
= TcLclEnv {
tcl_loc :: SrcSpan, -- Source span
tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
tcl_tclvl :: TcLevel, -- Birthplace for new unification variables
tcl_tclvl :: TcLevel, -- Birthplace for new unification variables
tcl_th_ctxt :: ThStage, -- Template Haskell context
tcl_th_bndrs :: ThBindEnv, -- Binding level of in-scope Names
......@@ -761,26 +761,22 @@ recording the environment when passing a proc (using newArrowScope),
and returning to that (using escapeArrowScope) on the left of -< and the
head of (|..|).
All this can be dealt with by the *renamer*; by the time we get to
the *type checker* we have sorted out the scopes
All this can be dealt with by the *renamer*. But the type checker needs
to be involved too. Example (arrowfail001)
class Foo a where foo :: a -> ()
data Bar = forall a. Foo a => Bar a
get :: Bar -> ()
get = proc x -> case x of Bar a -> foo -< a
Here the call of 'foo' gives rise to a (Foo a) constraint that should not
be captured by the pattern match on 'Bar'. Rather it should join the
constraints from further out. So we must capture the constraint bag
from further out in the ArrowCtxt that we push inwards.
-}
data ArrowCtxt
data ArrowCtxt -- Note [Escaping the arrow scope]
= NoArrowCtxt
| ArrowCtxt (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 $ \ env -> case tcl_arrow_ctxt (env_lcl env) of
NoArrowCtxt -> env
ArrowCtxt env' -> env'
| ArrowCtxt LocalRdrEnv (TcRef WantedConstraints)
---------------------------
-- TcTyThing
......
......@@ -24,4 +24,4 @@ T5380.hs:7:34:
testB :: not_bool -> (() -> ()) -> () -> not_unit
(bound at T5380.hs:7:1)
In the expression: f
In the expression: proc () -> if b then f -< () else f -< ()
In the command: f -< ()
setTestOpts(only_compiler_types(['ghc']))
test('arrowfail001',
when(compiler_debugged(), expect_broken(5267)),
normal,
compile_fail,
[''])
# arrowfail001 gets an ASSERT error in the stage1 compiler
# arrowfail001 got an ASSERT error in the stage1 compiler
# because we simply are not typechecking arrow commands
# correcly. See Trac #5267, #5609, #5605
# correctly. See Trac #5267, #5609, #5605
# The fix is patch 'Fix the scope-nesting for arrows' Dec 2014
test('arrowfail002', normal, compile_fail, [''])
test('arrowfail003', normal, compile_fail, [''])
......
......@@ -2,6 +2,5 @@
arrowfail001.hs:16:36:
No instance for (Foo a) arising from a use of ‘foo’
In the expression: foo
In the expression: proc x -> case x of { Bar a -> foo -< a }
In an equation for ‘get’:
get = proc x -> case x of { Bar a -> foo -< a }
In the command: foo -< a
In a case alternative: Bar a -> foo -< a
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