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.

1 files changed, 19 insertions, 6 deletions

diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 563505e373..2215ed1210 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1674,7 +1674,8 @@ data HsMatchContext p
   | LambdaExpr                  -- ^Patterns of a lambda
   | CaseAlt                     -- ^Patterns and guards on a case alternative
   | IfAlt                       -- ^Guards of a multi-way if alternative
-  | ProcExpr                    -- ^Patterns of a proc
+  | ArrowMatchCtxt              -- ^A pattern match inside arrow notation
+      HsArrowMatchContext
   | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e
   | PatBindGuards               -- ^Guards of pattern bindings, e.g.,
                                 --    (Just b) | Just _ <- x = e
@@ -1705,6 +1706,12 @@ data HsStmtContext p
   | TransStmtCtxt (HsStmtContext p)  -- ^A branch of a transform stmt
   | ArrowExpr                        -- ^do-notation in an arrow-command context
 
+-- | Haskell arrow match context.
+data HsArrowMatchContext
+  = ProcExpr     -- ^ A proc expression
+  | ArrowCaseAlt -- ^ A case alternative inside arrow notation
+  | KappaExpr    -- ^ An arrow kappa abstraction
+
 data HsDoFlavour
   = DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }
   | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression
@@ -1767,7 +1774,7 @@ matchSeparator (FunRhs {})   = text "="
 matchSeparator CaseAlt       = text "->"
 matchSeparator IfAlt         = text "->"
 matchSeparator LambdaExpr    = text "->"
-matchSeparator ProcExpr      = text "->"
+matchSeparator (ArrowMatchCtxt{})= text "->"
 matchSeparator PatBindRhs    = text "="
 matchSeparator PatBindGuards = text "="
 matchSeparator (StmtCtxt _)  = text "<-"
@@ -1783,9 +1790,10 @@ pprMatchContext ctxt
   | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
   | otherwise    = text "a"  <+> pprMatchContextNoun ctxt
   where
-    want_an (FunRhs {}) = True  -- Use "an" in front
-    want_an ProcExpr    = True
-    want_an _           = False
+    want_an (FunRhs {})                = True  -- Use "an" in front
+    want_an (ArrowMatchCtxt ProcExpr)  = True
+    want_an (ArrowMatchCtxt KappaExpr) = True
+    want_an _                          = False
 
 pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
                     => HsMatchContext p -> SDoc
@@ -1800,11 +1808,16 @@ pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"
 pprMatchContextNoun PatBindRhs      = text "pattern binding"
 pprMatchContextNoun PatBindGuards   = text "pattern binding guards"
 pprMatchContextNoun LambdaExpr      = text "lambda abstraction"
-pprMatchContextNoun ProcExpr        = text "arrow abstraction"
+pprMatchContextNoun (ArrowMatchCtxt c)= pprArrowMatchContextNoun c
 pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
                                       $$ pprAStmtContext ctxt
 pprMatchContextNoun PatSyn          = text "pattern synonym declaration"
 
+pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc
+pprArrowMatchContextNoun ProcExpr     = text "arrow proc pattern"
+pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"
+pprArrowMatchContextNoun KappaExpr    = text "arrow kappa abstraction"
+
 -----------------
 pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
                                 => HsStmtContext p -> SDoc