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

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