Reject GADT pattern matches in arrow notation

  Tickets #20469 and #20470 showed that the current
  implementation of arrows is not at all up to the task
  of supporting GADTs: GHC produces ill-scoped Core programs
  because it doesn't propagate the evidence introduced by a GADT
  pattern match.

  For the time being, we reject GADT pattern matches in arrow notation.
  Hopefully we are able to add proper support for GADTs in arrows
  in the future.

2 files changed, 12 insertions, 9 deletions

diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index a4c3ab9865..1e4c43cf7d 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1220,13 +1220,16 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
 
 emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage
 emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $
-  hang (text "Empty list of alternatives in" <+> pp_ctxt)
+  hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)
         2 (text "Use EmptyCase to allow this")
   where
-    pp_ctxt = case ctxt of
-                CaseAlt    -> text "case expression"
-                LambdaExpr -> text "\\case expression"
-                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
+    pp_ctxt :: HsMatchContext GhcRn -> SDoc
+    pp_ctxt c = case c of
+      CaseAlt       -> text "case expression"
+      LambdaExpr    -> text "\\case expression"
+      ArrowMatchCtxt ArrowCaseAlt -> text "case expression"
+      ArrowMatchCtxt KappaExpr    -> text "kappa abstraction"
+      _             -> text "(unexpected)" <+> pprMatchContextNoun c
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 93949c5d83..c7ef4dcfbd 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -553,7 +553,7 @@ rnExpr e@(HsStatic _ expr) = do
 
 rnExpr (HsProc x pat body)
   = newArrowScope $
-    rnPat ProcExpr pat $ \ pat' -> do
+    rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do
       { (body',fvBody) <- rnCmdTop body
       ; return (HsProc x pat' body', fvBody) }
 
@@ -798,7 +798,7 @@ rnCmd (HsCmdApp x fun arg)
        ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
 
 rnCmd (HsCmdLam _ matches)
-  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
+  = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches
        ; return (HsCmdLam noExtField matches', fvMatch) }
 
 rnCmd (HsCmdPar x lpar e rpar)
@@ -807,12 +807,12 @@ rnCmd (HsCmdPar x lpar e rpar)
 
 rnCmd (HsCmdCase _ expr matches)
   = do { (new_expr, e_fvs) <- rnLExpr expr
-       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
+       ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
        ; return (HsCmdCase noExtField new_expr new_matches
                 , e_fvs `plusFV` ms_fvs) }
 
 rnCmd (HsCmdLamCase x matches)
-  = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
+  = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
        ; return (HsCmdLamCase x new_matches, ms_fvs) }
 
 rnCmd (HsCmdIf _ _ p b1 b2)