diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-16 17:34:26 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-17 14:43:10 +0000 |
commit | f50d62bb6c0357991fabf938bc971d528bbf5cc4 (patch) | |
tree | 9c22376653e11cd99487401e09a5be99befa7788 | |
parent | 75c211ecafad890854f4a1f3e527bd42b13fc516 (diff) | |
download | haskell-f50d62bb6c0357991fabf938bc971d528bbf5cc4.tar.gz |
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
-rw-r--r-- | compiler/typecheck/TcArrows.hs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 22 | ||||
-rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 34 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_fail/T5380.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_fail/all.T | 7 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_fail/arrowfail001.stderr | 5 |
6 files changed, 45 insertions, 28 deletions
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index f1546b4e42..b4c3bcc60f 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 013b8a4ab0..77f2f6189f 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -380,6 +380,28 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS 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 } + +{- +************************************************************************ +* * Unique supply * * ************************************************************************ diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 7035bf310d..260a636ac8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -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 diff --git a/testsuite/tests/arrows/should_fail/T5380.stderr b/testsuite/tests/arrows/should_fail/T5380.stderr index 02e65c5366..1f8d4518fb 100644 --- a/testsuite/tests/arrows/should_fail/T5380.stderr +++ b/testsuite/tests/arrows/should_fail/T5380.stderr @@ -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 -< () diff --git a/testsuite/tests/arrows/should_fail/all.T b/testsuite/tests/arrows/should_fail/all.T index 6b7920d318..b798860083 100644 --- a/testsuite/tests/arrows/should_fail/all.T +++ b/testsuite/tests/arrows/should_fail/all.T @@ -1,12 +1,13 @@ 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, ['']) diff --git a/testsuite/tests/arrows/should_fail/arrowfail001.stderr b/testsuite/tests/arrows/should_fail/arrowfail001.stderr index 5c448c7a16..7805f80bf5 100644 --- a/testsuite/tests/arrows/should_fail/arrowfail001.stderr +++ b/testsuite/tests/arrows/should_fail/arrowfail001.stderr @@ -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 |