[commit: ghc] master: Fix the scope-nesting for arrows (f50d62b)
git at git.haskell.org
git at git.haskell.org
Wed Dec 17 14:45:39 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/f50d62bb6c0357991fabf938bc971d528bbf5cc4/ghc
>---------------------------------------------------------------
commit f50d62bb6c0357991fabf938bc971d528bbf5cc4
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Dec 16 17:34:26 2014 +0000
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
>---------------------------------------------------------------
f50d62bb6c0357991fabf938bc971d528bbf5cc4
compiler/typecheck/TcArrows.hs | 3 +-
compiler/typecheck/TcRnMonad.hs | 22 ++++++++++++++
compiler/typecheck/TcRnTypes.hs | 34 ++++++++++------------
testsuite/tests/arrows/should_fail/T5380.stderr | 2 +-
testsuite/tests/arrows/should_fail/all.T | 7 +++--
.../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 f1546b4..b4c3bcc 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 013b8a4..77f2f61 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 7035bf3..260a636 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 02e65c5..1f8d451 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 6b7920d..b798860 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 5c448c7..7805f80 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
More information about the ghc-commits
mailing list