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, 15 insertions, 3 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 83e36edf54..d6785c2a96 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1857,7 +1857,7 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
   ppr LambdaExpr            = text "LambdaExpr"
   ppr CaseAlt               = text "CaseAlt"
   ppr IfAlt                 = text "IfAlt"
-  ppr ProcExpr              = text "ProcExpr"
+  ppr (ArrowMatchCtxt c)    = text "ArrowMatchCtxt" <+> ppr c
   ppr PatBindRhs            = text "PatBindRhs"
   ppr PatBindGuards         = text "PatBindGuards"
   ppr RecUpd                = text "RecUpd"
@@ -1866,6 +1866,11 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
   ppr ThPatQuote            = text "ThPatQuote"
   ppr PatSyn                = text "PatSyn"
 
+instance Outputable HsArrowMatchContext where
+  ppr ProcExpr     = text "ProcExpr"
+  ppr ArrowCaseAlt = text "ArrowCaseAlt"
+  ppr KappaExpr    = text "KappaExpr"
+
 -----------------
 
 instance OutputableBndrId p
@@ -1882,16 +1887,21 @@ matchContextErrString PatBindRhs                 = text "pattern binding"
 matchContextErrString PatBindGuards              = text "pattern binding guards"
 matchContextErrString RecUpd                     = text "record update"
 matchContextErrString LambdaExpr                 = text "lambda"
-matchContextErrString ProcExpr                   = text "proc"
+matchContextErrString (ArrowMatchCtxt c)         = matchArrowContextErrString c
 matchContextErrString ThPatSplice                = panic "matchContextErrString"  -- Not used at runtime
 matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime
 matchContextErrString PatSyn                     = panic "matchContextErrString"  -- Not used at runtime
 matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"
-matchContextErrString (StmtCtxt (ArrowExpr))  = text "'do' block"
+matchContextErrString (StmtCtxt (ArrowExpr))       = text "'do' block"
 matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
 
+matchArrowContextErrString :: HsArrowMatchContext -> SDoc
+matchArrowContextErrString ProcExpr     = text "proc"
+matchArrowContextErrString ArrowCaseAlt = text "case"
+matchArrowContextErrString KappaExpr    = text "kappa"
+
 matchDoContextErrString :: HsDoFlavour -> SDoc
 matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
 matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 78a663d7fa..21cd9b5d76 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -366,6 +366,8 @@ deriving instance Data (HsStmtContext GhcPs)
 deriving instance Data (HsStmtContext GhcRn)
 deriving instance Data (HsStmtContext GhcTc)
 
+deriving instance Data HsArrowMatchContext
+
 deriving instance Data HsDoFlavour
 
 deriving instance Data (HsMatchContext GhcPs)