Prohibit TyAppswip/or-pats-amendment

8 files changed, 60 insertions, 17 deletions

diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 8b676d42f5..d64910358f 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -47,6 +47,8 @@ module GHC.Hs.Pat (
 
         collectEvVarsPat, collectEvVarsPats,
 
+        patHasTyAppsL,
+
         pprParendLPat, pprConArgs,
         pprLPat
     ) where
@@ -732,6 +734,7 @@ collectEvVarsPat pat =
     BangPat _ p      -> collectEvVarsLPat p
     ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
     TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
+    OrPat _ ps       -> unionManyBags $ map collectEvVarsLPat ps
     SumPat _ p _ _   -> collectEvVarsLPat p
     ConPat
       { pat_args  = args
@@ -750,6 +753,29 @@ collectEvVarsPat pat =
     _other_pat       -> emptyBag
 
 {-
+% True if the pattern contains a type application, ignoring nested or-patterns.
+-}
+patHasTyApps :: Pat GhcPs -> Bool
+patHasTyApps pat =
+  case pat of
+    LazyPat _ p      -> patHasTyAppsL p
+    AsPat _ _ _ p    -> patHasTyAppsL p
+    ParPat  _ _ p _  -> patHasTyAppsL p
+    BangPat _ p      -> patHasTyAppsL p
+    ListPat _ ps     -> any patHasTyAppsL ps
+    TuplePat _ ps _  -> any patHasTyAppsL ps
+    OrPat _ _        -> False -- this prohibits redundant error messages
+    SumPat _ p _ _   -> patHasTyAppsL p
+    ConPat { pat_args  = args } -> case args of
+      PrefixCon ts ps -> not (null ts) || any patHasTyAppsL ps
+      RecCon fs       -> any (patHasTyAppsL . hfbRHS . unXRec @GhcPs) (rec_flds fs)
+      InfixCon p1 p2  -> any patHasTyAppsL [p1,p2]
+    SigPat  _ p _    -> patHasTyAppsL p
+    _other_pat       -> False
+
+patHasTyAppsL :: GenLocated l (Pat GhcPs) -> Bool
+patHasTyAppsL = patHasTyApps . unLoc
+{-
 ************************************************************************
 *                                                                      *
 \subsection{Anno instances}
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index cd3d42701f..501cda7b78 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1220,7 +1220,7 @@ collect_pat flag pat bndrs = case pat of
   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats
   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats
   -- Evidence binders in an OrPat currently aren't visible outside their
-  -- binding pattern. This makes error messages more specific.
+  -- binding pattern. This prohibits redundant error messages.
   OrPat _ _             -> []
   SumPat _ pat _ _      -> collect_lpat flag pat bndrs
   LitPat _ _            -> bndrs
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index d2bbb3bbef..426ce97e6b 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -44,6 +44,7 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
 import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )
 
 import GHC.Hs
+import GHC.Hs.Pat ( patHasTyAppsL )
 import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Zonk   ( hsOverLitName )
@@ -612,7 +613,12 @@ rnPatAndThen mk (TuplePat _ pats boxed)
 
 rnPatAndThen mk (OrPat _ pats)
   = do { pats' <- rnLPatsAndThen mk pats
-       ; return (OrPat noExtField pats') }
+       ; let orpat :: Pat GhcRn = OrPat noExtField pats'
+       ; let varBnds = collectPatsBinders CollNoDictBinders pats
+        -- mapM_ (\(b,i) -> pprTraceM ("bnds " ++ show i) b) (zip (map ppr bnds) [0..])
+       ; liftCps $ checkErr (null varBnds) (TcRnOrPatBindsVariables orpat)
+       ; liftCps $ checkErr (not $ any patHasTyAppsL pats) (TcRnOrPatHasVisibleTyApps orpat)
+       ; return orpat }
 
 rnPatAndThen mk (SumPat _ pat alt arity)
   = do { pat <- rnLPatAndThen mk pat
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index b17c1c050b..1d14a52bce 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1246,9 +1246,12 @@ instance Diagnostic TcRnMessage where
                            False -> text (TH.pprint item))
     TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg
     TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc
-    TcRnOrPatBindsVariables pat vars -> case vars of
-      True -> mkSimpleDecorated $ text "An or-pattern may not bind (type) variables:" <+> ppr pat
-      False -> mkSimpleDecorated $ text "An or-pattern may not bind (type) variables nor type class or equality constraints:" <+> ppr pat
+    TcRnOrPatBindsVariables pat
+      -> mkSimpleDecorated $
+        text "An or-pattern may not bind variables:" <+> ppr pat
+    TcRnOrPatHasVisibleTyApps pat
+      -> mkSimpleDecorated $
+        text "An or-pattern may not contain visible type applications:" <+> ppr pat
     TcRnUnsatisfiedMinimalDef mindef
       -> mkSimpleDecorated $
         vcat [text "No explicit implementation for"
@@ -2095,6 +2098,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnOrPatBindsVariables{}
       -> ErrorWithoutFlag
+    TcRnOrPatHasVisibleTyApps{}
+      -> ErrorWithoutFlag
     TcRnUnsatisfiedMinimalDef{}
       -> WarningWithFlag (Opt_WarnMissingMethods)
     TcRnMisplacedInstSig{}
@@ -2673,6 +2678,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnOrPatBindsVariables{}
       -> noHints
+    TcRnOrPatHasVisibleTyApps{}
+      -> noHints
     TcRnUnsatisfiedMinimalDef{}
       -> noHints
     TcRnMisplacedInstSig{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index bce545eade..8188146d26 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2730,15 +2730,24 @@ data TcRnMessage where
   -}
   TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage
 
-  {-| TcRnOrPatBindsVariables is an error that happens when an
-     or-pattern binds variables or has dictionary or evidence biders, e.g. (one of A, B x).
+  {-| TcRnOrPatBindsVariables is an error that happens when
+     a pattern nested in an or-pattern binds variables, e.g. (one of A; B x).
 
      Test case:
      testsuite/tests/typecheck/should_fail/Or3
   -}
   TcRnOrPatBindsVariables
-    :: Pat GhcTc -- the or-pattern
-    -> Bool -- True => pattern contains just (type) variables; False => pattern contains other dictionary/evidence binders
+    :: Pat GhcRn -- the or-pattern
+    -> TcRnMessage
+
+    {-| TcRnOrPatHasVisibleTyApps is an error that happens when
+     a pattern nested in an or-pattern uses a visible type application e.g. (one of Just @Int _).
+
+     Test case:
+     todo
+  -}
+  TcRnOrPatHasVisibleTyApps
+    :: Pat GhcRn -- the or-pattern
     -> TcRnMessage
 
   {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 57a2288223..b66f54c6ef 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -402,7 +402,8 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
         ; return (BangPat x pat', res) }
 
   OrPat _ pats -> do -- or-patterns with variables are rejected later, after zonking
-    { (pats', res) <- tc_lpats (map (const pat_ty) pats) penv pats thing_inside
+    { (pats', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats) penv pats (captureConstraints thing_inside)
+    ; emitConstraints pat_ct
     ; pat_ty <- expTypeToType (scaledThing pat_ty)
     ; return (OrPat pat_ty pats', res) }
 
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 5b79a2987a..78dd4a2eff 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1347,14 +1347,7 @@ zonk_pat env (TuplePat tys pats boxed)
 zonk_pat env p@(OrPat ty pats)
   = do  { ty' <- zonkTcTypeToTypeX env ty
         ; (env', pats') <- zonkPats env pats
-        ; checkNoVarsBound pats' p
         ; return (env', OrPat ty' pats') }
-    where
-      checkNoVarsBound :: [LPat GhcTc] -> Pat GhcTc -> TcRn ()
-      checkNoVarsBound pats orpat = do
-        let bnds = collectPatsBinders CollWithDictBinders pats
-        let varBnds = collectPatsBinders CollNoDictBinders pats
-        unless (null bnds) $ addErr (TcRnOrPatBindsVariables orpat (varBnds `equalLength` bnds))
 
 zonk_pat env (SumPat tys pat alt arity )
   = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 986284baf7..f57b3439fa 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -473,6 +473,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnSpecialiseNotVisible"                      = 85337
   GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl"                   = 50649
   GhcDiagnosticCode "TcRnOrPatBindsVariables"                       = 81303
+  GhcDiagnosticCode "TcRnOrPatHasVisibleTyApps"                     = 28418
   GhcDiagnosticCode "TcRnBindVarAlreadyInScope"                     = 69710
   GhcDiagnosticCode "TcRnBindMultipleVariables"                     = 92957
   GhcDiagnosticCode "TcRnIllegalKind"                               = 64861