Add Or Patterns (proposal 0522)

37 files changed, 355 insertions, 36 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 57d89a15b1..6ddfcf8063 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3720,6 +3720,7 @@ xFlagsDeps = [
   depFlagSpec' "NullaryTypeClasses"           LangExt.NullaryTypeClasses
     (deprecatedForExtension "MultiParamTypeClasses"),
   flagSpec "NumDecimals"                      LangExt.NumDecimals,
+  flagSpec "OrPatterns"                       LangExt.OrPatterns,
   depFlagSpecOp "OverlappingInstances"        LangExt.OverlappingInstances
     setOverlappingInsts
     "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 39a788aab5..3d7bc99860 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -84,6 +84,7 @@ import GHC.Data.Maybe
 import GHC.Types.Name (Name, dataName)
 import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
+import GHC.Exts (toList)
 import Data.Data
 
 
@@ -121,6 +122,10 @@ type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
 type instance XTuplePat GhcRn = NoExtField
 type instance XTuplePat GhcTc = [Type]
 
+type instance XOrPat GhcPs = NoExtField
+type instance XOrPat GhcRn = NoExtField
+type instance XOrPat GhcTc = Type
+
 type instance XSumPat GhcPs = EpAnn EpAnnSumPat
 type instance XSumPat GhcRn = NoExtField
 type instance XSumPat GhcTc = [Type]
@@ -348,6 +353,7 @@ pprPat (SplicePat ext splice)   =
       GhcTc -> dataConCantHappen ext
 pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty
 pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
+pprPat (OrPat _ pats)           = text "one of" <+> pprWithCommas ppr (toList pats)
 pprPat (TuplePat _ pats bx)
     -- Special-case unary boxed tuples so that they are pretty-printed as
     -- `Solo x`, not `(x)`
@@ -570,6 +576,7 @@ isIrrefutableHsPat' is_strict = goL
     go (SumPat {})         = False
                     -- See Note [Unboxed sum patterns aren't irrefutable]
     go (ListPat {})        = False
+    go (OrPat _ pats)      = any (isIrrefutableHsPat' is_strict) pats
 
     go (ConPat
         { pat_con  = con
@@ -648,6 +655,7 @@ patNeedsParens p = go @p
     -- at a different GhcPass (see the case for GhcTc XPat below).
     go :: forall q. IsPass q => Pat (GhcPass q) -> Bool
     go (NPlusKPat {})    = p > opPrec
+    go (OrPat {})        = False
     go (SplicePat {})    = False
     go (ConPat { pat_args = ds })
                          = conPatNeedsParens p ds
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 6310a0f3c9..47a5afc855 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -51,6 +51,7 @@ hsPatType (LitPat _ lit)                = hsLitType lit
 hsPatType (AsPat _ var _ _)             = idType (unLoc var)
 hsPatType (ViewPat ty _ _)              = ty
 hsPatType (ListPat ty _)                = mkListTy ty
+hsPatType (OrPat ty _)                  = ty
 hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index af222bf98a..f6fee5c8d9 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1159,6 +1159,7 @@ collect_pat flag pat bndrs = case pat of
   ParPat _ _ pat _      -> collect_lpat flag pat bndrs
   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats
   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats
+  OrPat _ _             -> [] -- Don't collect binders recursively as we only want to get an error in the most specific or-pattern
   SumPat _ pat _ _      -> collect_lpat flag pat bndrs
   LitPat _ _            -> bndrs
   NPat {}               -> bndrs
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 0cf83d378c..1110208a12 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -6,6 +6,9 @@
 {-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -227,7 +230,7 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
     match_groups (g:gs) = mapM match_group $ g :| gs
 
     match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
-    match_group eqns@((group,_) :| _)
+    match_group eqns@((group,eq) :| _)
         = case group of
             PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
             PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
@@ -239,6 +242,7 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
             PgBang    -> matchBangs      vars ty (dropGroup eqns)
             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
             PgView {} -> matchView       vars ty (dropGroup eqns)
+            PgOr      -> matchOr         vars ty eq -- every or-pattern makes up a single PgOr group
       where eqns' = NEL.toList eqns
             ne l = case NEL.nonEmpty l of
               Just nel -> nel
@@ -307,6 +311,18 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
                     (mkCoreAppDs (text "matchView") viewExpr' (Var var))
                     match_result) }
 
+matchOr :: NonEmpty MatchId -> Type -> EquationInfo -> DsM (MatchResult CoreExpr)
+matchOr (var :| vars) ty eqn = do {
+      let OrPat _ pats = firstPat eqn
+     -- what to do *after* the OrPat matches
+    ; match_result <- match vars ty [eqn { eqn_pats = tail (eqn_pats eqn) }]
+     -- share match_result across the different cases of the OrPat match
+    ; shareSuccessHandler match_result ty (\expr -> do {
+      let or_eqns = map (singleEqn expr) (NEL.toList pats) in match [var] ty or_eqns
+    })
+  } where
+    singleEqn expr (L _ pat) = EqnInfo { eqn_pats = [pat], eqn_orig = FromSource, eqn_rhs = pure expr }
+
 -- decompose the first pattern and leave the rest alone
 decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
@@ -428,6 +444,11 @@ tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
 tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
 tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
 
+tidy1 v o (OrPat x pats) = do
+  (wraps, pats) <- mapAndUnzipM (tidy1 v o . unLoc) (NEL.toList pats)
+  let wrap = foldr (.) id wraps in
+    return (wrap, OrPat x (NEL.fromList $ map (L noSrcSpanA) pats))
+
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
 tidy1 v _ (VarPat _ (L _ var))
@@ -927,6 +948,7 @@ data PatGroup
   | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
                         -- the LHsExpr is the expression e
            Type         -- the Type is the type of p (equivalently, the result type of e)
+  | PgOr                -- Or pattern
 
 {- Note [Don't use Literal for PgN]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1197,6 +1219,7 @@ patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit)
 patGroup platform (XPat ext) = case ext of
   CoPat _ p _      -> PgCo (hsPatType p) -- Type of innelexp pattern
   ExpansionPat _ p -> patGroup platform p
+patGroup _ (OrPat {}) = PgOr
 patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
 
 {-
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 8ebe472d5f..342994c5c4 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -238,6 +238,8 @@ desugarPat x pat = case pat of
     let tuple_con = tupleDataCon boxity (length vars)
     pure $ vanillaConGrd x tuple_con vars : concat grdss
 
+  OrPat _tys pats -> concatMapM (desugarLPat x) (NE.toList pats)
+
   SumPat _ty p alt arity -> do
     (y, grds) <- desugarLPatV p
     let sum_con = sumDataCon alt arity
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index a64c8b74bc..612e00ffa2 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -21,7 +21,7 @@ module GHC.HsToCore.Utils (
         cantFailMatchResult, alwaysFailMatchResult,
         extractMatchResult, combineMatchResults,
         adjustMatchResultDs,
-        shareFailureHandler,
+        shareFailureHandler, shareSuccessHandler,
         dsHandleMonadicFailure,
         mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
         matchCanFail, mkEvalMatchResult,
@@ -906,31 +906,46 @@ carefully), but we certainly don't support it now.
 anyway, and the Void# doesn't do much harm.
 -}
 
-mkFailurePair :: CoreExpr       -- Result type of the whole case expression
-              -> DsM (CoreBind, -- Binds the newly-created fail variable
-                                -- to \ _ -> expression
-                      CoreExpr) -- Fail variable applied to realWorld#
+mkSharedPair :: FastString  -- Name of the newly created variable
+             -> Type        -- Type of the expression to share
+             -> DsM (CoreExpr -> (CoreExpr -> CoreExpr),
+                     -- Given the expression to share, returns a float that
+                     -- wraps a NonRec let around the expression for the shared
+                     -- binding
+                     CoreExpr)
+                     -- Fail variable applied to (# #)
+mkSharedPair fun_name ty
+  = do { fun_var <- mkSysLocalM fun_name ManyTy (unboxedUnitTy `mkVisFunTyMany` ty)
+       ; fun_arg <- newSysLocalDs ManyTy unboxedUnitTy
+       ; let real_arg = setOneShotLambda fun_arg
+       ; return (Let . NonRec fun_var . Lam real_arg,
+                 App (Var fun_var) unboxedUnitExpr) }
+
+mkFailurePair :: Type -> DsM (CoreExpr -> (CoreExpr -> CoreExpr), CoreExpr)
 -- See Note [Failure thunks and CPR]
-mkFailurePair expr
-  = do { fail_fun_var <- newFailLocalDs ManyTy (unboxedUnitTy `mkVisFunTyMany` ty)
-       ; fail_fun_arg <- newSysLocalDs ManyTy unboxedUnitTy
-       ; let real_arg = setOneShotLambda fail_fun_arg
-       ; return (NonRec fail_fun_var (Lam real_arg expr),
-                 App (Var fail_fun_var) unboxedUnitExpr) }
-  where
-    ty = exprType expr
+mkFailurePair = mkSharedPair (fsLit "fail")
+
+mkSuccessPair :: Type -> DsM (CoreExpr -> (CoreExpr -> CoreExpr), CoreExpr)
+mkSuccessPair = mkSharedPair (fsLit "success")
 
--- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have
--- neither a failure arg or failure "hole", so nothing is let-bound, and no
+-- Uses '@mkSharedPair@' to bind the failure case. Infallible matches have
+-- neither a failure arg nor failure "hole", so nothing is let-bound, and no
 -- extraneous Core is produced.
 shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr
 shareFailureHandler = \case
   mr@(MR_Infallible _) -> mr
   MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do
-    (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr
-    body <- match_fn shared_failure_handler
+    (mk_fail_bind, shared_failure_handler) <- mkFailurePair (exprType fail_expr)
     -- Never unboxed, per the above, so always OK for `let` not `case`.
-    return $ Let fail_bind body
+    mk_fail_bind fail_expr <$> match_fn shared_failure_handler
+
+-- Uses '@mkSharedPair@' to bind the success case
+shareSuccessHandler :: MatchResult CoreExpr -> Type -> (CoreExpr -> DsM (MatchResult CoreExpr)) -> DsM (MatchResult CoreExpr)
+shareSuccessHandler success_result ty match_body = do
+  (mk_success_bind, shared_success_handler) <- mkSuccessPair ty
+  -- Never unboxed, per the above, so always OK for `let` not `case`.
+  body_result <- match_body shared_success_handler
+  pure (mk_success_bind <$> success_result <*> body_result)
 
 {-
 Note [Failure thunks and CPR]
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 8ede7bcc5f..26a73d3777 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -970,6 +970,8 @@ instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where
 instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
   toHie (PS rsp scope pscope lpat@(L ospan opat)) =
     concatM $ getTypeNode lpat : case opat of
+      OrPat _ pats ->
+        map (toHie . PS rsp scope pscope) (NE.toList pats)
       WildPat _ ->
         []
       VarPat _ lname ->
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 2648552bee..f994f4fdaf 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -507,6 +507,22 @@ Ambiguity:
     empty activation and inlining '[0] Something'.
 -}
 
+{- Note [%shift: orpats -> pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Context:
+    orpats -> pat .
+    orpats -> pat . ',' orpats
+
+Example:
+
+    (one of a, b)
+
+Ambiguity:
+    We use ',' as a delimiter between options inside an or-pattern.
+    However, the ',' could also mean a tuple pattern.
+    If the user wants a tuple pattern, they have to put the or-pattern in parentheses.
+-}
+
 {- Note [Parser API Annotations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A lot of the productions are now cluttered with calls to
@@ -605,6 +621,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  'interruptible' { L _ ITinterruptible }
  'unsafe'       { L _ ITunsafe }
  'family'       { L _ ITfamily }
+ 'one'          { L _ ITone }
  'role'         { L _ ITrole }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
@@ -3051,12 +3068,25 @@ texp :: { ECP }
                                 $1 >>= \ $1 ->
                                 pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
 
+        | 'one' 'of' vocurly orpats close
+                             {% do {
+                                    let pat = sLLa $1 (reLoc (last $4)) (OrPat NoExtField (NE.fromList $4))
+                                    ; orPatsOn <- hintOrPats pat
+                                    ; when (orPatsOn && length $4 < 2) $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) (PsErrOrPatNeedsTwoAlternatives pat)
+                                    ; return $ ecpFromPat pat
+                             }  }
+
        -- View patterns get parenthesized above
         | exp '->' texp   { ECP $
                              unECP $1 >>= \ $1 ->
                              unECP $3 >>= \ $3 ->
                              mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }
 
+orpats :: { [LPat GhcPs] }
+        : tpat %shift      { [$1] }
+
+        | tpat ',' orpats  { $1 : $3 }
+
 -- Always at least one comma or bar.
 -- Though this can parse just commas (without any expressions), it won't
 -- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]
@@ -3320,6 +3350,9 @@ gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }
 pat     :: { LPat GhcPs }
 pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }
 
+tpat     :: { LPat GhcPs }
+tpat     :  texp          {% (checkPattern <=< runPV) (unECP $1) }
+
 -- 'pats1' does the same thing as 'pat', but returns it as a singleton
 -- list so that it can be used with a parameterized production rule
 pats1   :: { [LPat GhcPs] }
@@ -3786,6 +3819,7 @@ varid :: { LocatedN RdrName }
         | 'forall'         { sL1n $1 $! mkUnqual varName (fsLit "forall") }
         | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }
         | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }
+        | 'one'            { sL1n $1 $! mkUnqual varName (fsLit "one") }
         -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'
         -- in GHC.Parser.PostProcess
         -- See Note [Parsing explicit foralls in Rules]
@@ -3812,8 +3846,8 @@ varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'
 
 -- These special_ids are treated as keywords in various places,
 -- but as ordinary ids elsewhere.   'special_id' collects all these
--- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and
--- 'anyclass', whose treatment differs depending on context
+-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', 'one'
+-- and 'anyclass', whose treatment differs depending on context
 special_id :: { Located FastString }
 special_id
         : 'as'                  { sL1 $1 (fsLit "as") }
@@ -4165,6 +4199,13 @@ looksLikeMult ty1 l_op ty2
   = True
   | otherwise = False
 
+-- Hint about or-patterns
+hintOrPats :: MonadP m => LPat GhcPs -> m Bool
+hintOrPats pat = do
+  orPatsEnabled <- getBit OrPatternsBit
+  unless orPatsEnabled $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) $ PsErrIllegalOrPat pat
+  return orPatsEnabled
+
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index aadb2a0a79..f2cdbb05fc 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -523,6 +523,13 @@ instance Diagnostic PsMessage where
                 , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma
                 , text "but it is not" ]
 
+    PsErrOrPatNeedsTwoAlternatives pat
+      -> mkSimpleDecorated $ vcat [text "An or-pattern needs at least two alternatives:" <+> ppr (unLoc pat)]
+
+    PsErrIllegalOrPat pat
+      -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)]
+
+
   diagnosticReason = \case
     PsUnknownMessage m                            -> diagnosticReason m
     PsHeaderMessage  m                            -> psHeaderMessageReason m
@@ -641,6 +648,8 @@ instance Diagnostic PsMessage where
     PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag
     PsErrMultipleConForNewtype {}                 -> ErrorWithoutFlag
     PsErrUnicodeCharLooksLike{}                   -> ErrorWithoutFlag
+    PsErrOrPatNeedsTwoAlternatives{}              -> ErrorWithoutFlag
+    PsErrIllegalOrPat{}                           -> ErrorWithoutFlag
 
   diagnosticHints = \case
     PsUnknownMessage m                            -> diagnosticHints m
@@ -812,6 +821,8 @@ instance Diagnostic PsMessage where
     PsErrInvalidCApiImport {}                     -> noHints
     PsErrMultipleConForNewtype {}                 -> noHints
     PsErrUnicodeCharLooksLike{}                   -> noHints
+    PsErrIllegalOrPat{}                           -> [suggestExtension LangExt.OrPatterns]
+    PsErrOrPatNeedsTwoAlternatives{}              -> noHints
 
   diagnosticCode = constructorCode
 
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 87f7f8d509..47b01534c0 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -471,6 +471,12 @@ data PsMessage
       Char -- ^ the character it looks like
       String -- ^ the name of the character that it looks like
 
+    -- | Or pattern used without -XOrPatterns
+    | PsErrIllegalOrPat (LPat GhcPs)
+
+    -- | Or pattern with just a single alternative like (one of x)
+    | PsErrOrPatNeedsTwoAlternatives (LPat GhcPs)
+
    deriving Generic
 
 -- | Extra details about a parse error, which helps
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 0f0f37075f..4c6441c72d 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -756,6 +756,7 @@ data Token
   | ITjavascriptcallconv
   | ITmdo (Maybe FastString)
   | ITfamily
+  | ITone
   | ITrole
   | ITgroup
   | ITby
@@ -996,6 +997,7 @@ reservedWordsFM = listToUFM $
          ( "mdo",            ITmdo Nothing,   xbit RecursiveDoBit),
              -- See Note [Lexing type pseudo-keywords]
          ( "family",         ITfamily,        0 ),
+         ( "one",            ITone,           0 ),
          ( "role",           ITrole,          0 ),
          ( "pattern",        ITpattern,       xbit PatternSynonymsBit),
          ( "static",         ITstatic,        xbit StaticPointersBit ),
@@ -2895,6 +2897,7 @@ data ExtBits
   | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]
   | OverloadedRecordDotBit
   | OverloadedRecordUpdateBit
+  | OrPatternsBit
 
   -- Flags that are updated once parsing starts
   | InRulePragBit
@@ -2974,6 +2977,7 @@ mkParserOpts extensionFlags diag_opts supported
       .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]
       .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot
       .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).
+      .|. OrPatternsBit               `xoptBit` LangExt.OrPatterns
     optBits =
           HaddockBit        `setBitIf` isHaddock
       .|. RawTokenStreamBit `setBitIf` rawTokStream
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 9c0a5df0aa..cae1191b76 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -9,6 +9,9 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
 
 --
 --  (c) The University of Glasgow 2002-2006
@@ -107,6 +110,7 @@ module GHC.Parser.PostProcess (
         DisambECP(..),
         ecpFromExp,
         ecpFromCmd,
+        ecpFromPat,
         PatBuilder,
 
         -- Type/datacon ambiguity resolution
@@ -164,7 +168,7 @@ import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 import Data.Kind       ( Type )
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty(..))
 
 {- **********************************************************************
 
@@ -1158,11 +1162,11 @@ checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (L
 checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
 
 checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(L l _) = checkPat l e [] []
+checkLPat e@(L l _) = checkFPat l e [] []
 
-checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
+checkFPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
          -> PV (LPat GhcPs)
-checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
+checkFPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
   | isRdrDataCon c = return . L loc $ ConPat
       { pat_con_ext = noAnn -- AZ: where should this come from?
       , pat_con = L ln c
@@ -1173,15 +1177,16 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
   | (not (null args) && patIsRec c) = do
       ctx <- askParseContext
       patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
-  checkPat loc f (HsConPatTyArg at t : tyargs) args
-checkPat loc (L _ (PatBuilderApp f e)) [] args = do
+  | otherwise = return $ L l (VarPat noExtField (L ln c))
+checkFPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
+  checkFPat loc f (HsConPatTyArg at t : tyargs) args
+checkFPat loc (L _ (PatBuilderApp f e)) [] args = do
   p <- checkLPat e
-  checkPat loc f [] (p : args)
-checkPat loc (L l e) [] [] = do
+  checkFPat loc f [] (p : args)
+checkFPat loc (L l e) [] [] = do
   p <- checkAPat loc e
   return (L l p)
-checkPat loc e _ _ = do
+checkFPat loc e _ _ = do
   details <- fromParseContext <$> askParseContext
   patFail (locA loc) (PsErrInPat (unLoc e) details)
 
@@ -1190,7 +1195,7 @@ checkAPat loc e0 = do
  nPlusKPatterns <- getBit NPlusKPatternsBit
  case e0 of
    PatBuilderPat p -> return p
-   PatBuilderVar x -> return (VarPat noExtField x)
+   PatBuilderVar _ -> unLoc <$> checkLPat (L loc e0)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
@@ -1226,7 +1231,15 @@ checkAPat loc e0 = do
      p <- checkLPat e
      return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar)
 
-   _           -> do
+   PatBuilderApp _ _ -> do
+    a <- checkFPat loc (L loc e0) [] []
+    return (unLoc a)
+
+   PatBuilderAppType {} -> do
+    a <- checkFPat loc (L loc e0) [] []
+    return (unLoc a)
+
+   _ -> do
      details <- fromParseContext <$> askParseContext
      patFail (locA loc) (PsErrInPat e0 details)
 
@@ -1452,6 +1465,9 @@ ecpFromExp a = ECP (ecpFromExp' a)
 ecpFromCmd :: LHsCmd GhcPs -> ECP
 ecpFromCmd a = ECP (ecpFromCmd' a)
 
+ecpFromPat :: LPat GhcPs -> ECP
+ecpFromPat a = ECP (ecpFromPat' a)
+
 -- The 'fbinds' parser rule produces values of this type. See Note
 -- [RecordDotSyntax field updates].
 type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))
@@ -1494,6 +1510,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
   ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
   -- | Return an expression without ambiguity, or fail in a non-expression context.
   ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
+  ecpFromPat' :: LPat GhcPs -> PV (LocatedA b)
   mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
     -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
   -- | Disambiguate "\... -> ..." (lambda)
@@ -1643,6 +1660,7 @@ instance DisambECP (HsCmd GhcPs) where
   type Body (HsCmd GhcPs) = HsCmd
   ecpFromCmd' = return
   ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)
+  ecpFromPat' (L l e) = cmdFail (locA l) (ppr e)
   mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
                                                  PsErrOverloadedRecordDotInvalid
   mkHsLamPV l mg = do
@@ -1727,6 +1745,7 @@ instance DisambECP (HsExpr GhcPs) where
     addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c
     return (L l (hsHoleExpr noAnn))
   ecpFromExp' = return
+  ecpFromPat' (L l e) = cmdFail (locA l) (ppr e)
   mkHsProjUpdatePV l fields arg isPun anns = do
     cs <- getCommentsFor l
     return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)
@@ -1826,6 +1845,7 @@ instance DisambECP (PatBuilder GhcPs) where
   type Body (PatBuilder GhcPs) = PatBuilder
   ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c
   ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e
+  ecpFromPat' p          = return $ L (getLoc p) (PatBuilderPat (unLoc p))
   mkHsLamPV l _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat
   mkHsLetPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
   mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
@@ -1847,6 +1867,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
   mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
+  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA (PatBuilder GhcPs))
   mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do
     checkUnboxedLitPat lit
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index fa5c7b8532..cfcdad14e8 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -537,6 +537,7 @@ isOkNoBindPattern (L _ pat) =
   case pat of
     WildPat{}       -> True -- Exception (1)
     BangPat {}      -> True -- Exception (2) #9127, #13646
+    OrPat {}        -> True
     p -> patternContainsSplice p -- Exception (3)
 
     where
@@ -552,6 +553,7 @@ isOkNoBindPattern (L _ pat) =
           -- The base cases
           VarPat {} -> False
           WildPat {} -> False
+          OrPat {} -> False
           LitPat {} -> False
           NPat {} -> False
           NPlusKPat {} -> False
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 95931ca4a1..7a4c9df9fd 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -2275,6 +2275,7 @@ isStrictPattern (L loc pat) =
     ParPat _ _ p _  -> isStrictPattern p
     ViewPat _ _ p   -> isStrictPattern p
     SigPat _ p _    -> isStrictPattern p
+    OrPat _ p       -> isStrictPattern (NE.head p)
     BangPat{}       -> True
     ListPat{}       -> True
     TuplePat{}      -> True
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 169c2e508c..1745f9744d 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -607,6 +607,10 @@ rnPatAndThen mk (TuplePat _ pats boxed)
   = do { pats' <- rnLPatsAndThen mk pats
        ; return (TuplePat noExtField pats' boxed) }
 
+rnPatAndThen mk (OrPat _ pats)
+  = do { pats' <- rnLPatsAndThen mk (NE.toList pats)
+       ; return (OrPat noExtField (NE.fromList pats')) }
+
 rnPatAndThen mk (SumPat _ pat alt arity)
   = do { pat <- rnLPatAndThen mk pat
        ; return (SumPat noExtField pat alt arity)
@@ -1002,4 +1006,4 @@ rnOverLit origLit
           then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
                   ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
                                   , fvs1 `plusFV` fvs2) }
-          else return ((lit', Nothing), fvs1) }
+          else return ((lit', Nothing), fvs1) }
\ No newline at end of file
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 984cf95903..9ced996c03 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1155,6 +1155,9 @@ 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 variables:" <+> ppr pat
+      False -> mkSimpleDecorated $ text "An or-pattern may not bind (type) variables nor type class or equality constraints:" <+> ppr pat
     TcRnUnsatisfiedMinimalDef mindef
       -> mkSimpleDecorated $
         vcat [text "No explicit implementation for"
@@ -1608,6 +1611,8 @@ instance Diagnostic TcRnMessage where
       -> if isError then ErrorWithoutFlag else WarningWithoutFlag
     TcRnInterfaceLookupError{}
       -> ErrorWithoutFlag
+    TcRnOrPatBindsVariables{}
+      -> ErrorWithoutFlag
     TcRnUnsatisfiedMinimalDef{}
       -> WarningWithFlag (Opt_WarnMissingMethods)
     TcRnMisplacedInstSig{}
@@ -2018,6 +2023,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnInterfaceLookupError{}
       -> noHints
+    TcRnOrPatBindsVariables{}
+      -> noHints
     TcRnUnsatisfiedMinimalDef{}
       -> noHints
     TcRnMisplacedInstSig{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 65701f9fee..d128ca1b26 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2559,6 +2559,17 @@ 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).
+
+     Test case:
+     testsuite/tests/typecheck/should_fail/Or3
+  -}
+  TcRnOrPatBindsVariables
+    :: Pat GhcTc -- the or-pattern
+    -> Bool -- True => pattern contains just variables; False => pattern contains other dictionary/evidence binders
+    -> TcRnMessage
+
   {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
        is missing methods that are required by the minimal definition.
 
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 35c2463cb6..a89f93e1db 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -5,6 +5,9 @@
 {-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -379,6 +382,11 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
         ; return (BangPat x pat', res) }
 
+  OrPat _ (NE.toList -> pats) -> do -- or-patterns with variables are rejected later, after zonking
+    { (pats', res) <- tc_lpats (map (const pat_ty) pats) penv pats thing_inside
+    ; pat_ty <- expTypeToType (scaledThing pat_ty)
+    ; return (OrPat pat_ty (NE.fromList pats'), res) }
+
   LazyPat x pat -> do
         { mult_wrap <- checkManyPattern pat_ty
             -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 8741770977..855a109891 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -1106,6 +1106,7 @@ tcPatToExpr name args pat = go pat
     go1 p@(WildPat {})                       = notInvertible p
     go1 p@(AsPat {})                         = notInvertible p
     go1 p@(NPlusKPat {})                     = notInvertible p
+    go1 p@(OrPat {})                         = notInvertible p
 
     notInvertible p = Left (not_invertible_msg p)
 
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 8c95d6f297..b14d306080 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Env   ( tcLookupGlobalOnly )
 import GHC.Tc.Types.Evidence
+import GHC.Tc.Errors.Types
 
 import GHC.Core.TyCo.Ppr     ( pprTyVar )
 import GHC.Core.TyCon
@@ -91,6 +92,7 @@ import GHC.Data.Bag
 
 import Control.Monad
 import Data.List  ( partition )
+import qualified Data.List.NonEmpty as NE
 import Control.Arrow ( second )
 
 {- *********************************************************************
@@ -1342,6 +1344,18 @@ zonk_pat env (TuplePat tys pats boxed)
         ; (env', pats') <- zonkPats env pats
         ; return (env', TuplePat tys' pats' boxed) }
 
+zonk_pat env p@(OrPat ty pats)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; (env', pats') <- zonkPats env (NE.toList pats)
+        ; checkNoVarsBound pats' p
+        ; return (env', OrPat ty' (NE.fromList 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
         ; (env', pat') <- zonkPat env pat
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 544ebc905f..2c73a476c7 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -268,6 +268,8 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "PsErrInvalidCApiImport"                        = 72744
   GhcDiagnosticCode "PsErrMultipleConForNewtype"                    = 05380
   GhcDiagnosticCode "PsErrUnicodeCharLooksLike"                     = 31623
+  GhcDiagnosticCode "PsErrIllegalOrPat"                             = 29847
+  GhcDiagnosticCode "PsErrOrPatNeedsTwoAlternatives"                = 96152
 
   -- Driver diagnostic codes
   GhcDiagnosticCode "DriverMissingHomeModules"                      = 32850
@@ -470,7 +472,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl"                   = 50649
   GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = 40027
   GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = 69639
-
+  GhcDiagnosticCode "TcRnOrPatBindsVariables"                       = 81303
   GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods"                 = 93006
   GhcDiagnosticCode "TcRnBadGenericMethod"                          = 59794
   GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete"               = 13511
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 9ad16c0cd7..ce1ac48647 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -66,7 +66,7 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension.
 -}
 
 -- | A placeholder type for TTG extension points that are not currently
--- unused to represent any particular value.
+-- used to represent any particular value.
 --
 -- This should not be confused with 'DataConCantHappen', which are found in unused
 -- extension /constructors/ and therefore should never be inhabited. In
@@ -591,6 +591,7 @@ type family XBangPat     x
 type family XListPat     x
 type family XTuplePat    x
 type family XSumPat      x
+type family XOrPat       x
 type family XConPat      x
 type family XViewPat     x
 type family XSplicePat   x
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs
index 66b9708bfe..80edb216a5 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs
+++ b/compiler/Language/Haskell/Syntax/Pat.hs
@@ -52,6 +52,7 @@ import Data.Ord
 import Data.Int
 import Data.Function
 import qualified Data.List
+import qualified Data.List.NonEmpty as NEL
 
 type LPat p = XRec p (Pat p)
 
@@ -137,6 +138,10 @@ data Pat p
     --            'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@,
     --            'GHC.Parser.Annotation.AnnClose' @')'@ or  @'#)'@
 
+  | OrPat       (XOrPat p)
+                (NEL.NonEmpty (LPat p))
+    -- ^ Or Pattern
+
   | SumPat      (XSumPat p)        -- after typechecker, types of the alternative
                 (LPat p)           -- Sum sub-pattern
                 ConTag             -- Alternative (one-based)
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index 532c290ba8..10fa7eefea 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -64,6 +64,7 @@ data Extension
    | RecordWildCards
    | NamedFieldPuns
    | ViewPatterns
+   | OrPatterns
    | GADTs
    | GADTSyntax
    | NPlusKPatterns
diff --git a/testsuite/tests/deSugar/should_run/Or4.hs b/testsuite/tests/deSugar/should_run/Or4.hs
new file mode 100644
index 0000000000..d1b603dda2
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/Or4.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Main where
+
+main = do
+  print ((f1 3) == 1)
+  print ((f1 5) == 3)
+  print ((f2 [0,2,4]) == 1)
+  print ((f2 [1,3]) == 2)
+  print ((f3 4 4) == True)
+  print ((f3 3 8) == True)
+  print (a3 == 3)
+  print (a4 == True)
+  print (a5 == True)
+  print (a6 == False)
+  print backtrack
+
+f1 x = case x of
+  3 -> 1
+  4 -> 2
+  (one of 3,4,5) -> 3
+
+f2 y = case y of
+  (one of _:2:_, 1:_) | length y /= 2 -> 1
+  (one of [1,2], 1:3:_)-> 2
+  (one of _, _) -> 3
+
+f3 :: (Eq a, Show a) => a -> a -> Bool
+f3 a (one of (== a) -> True, show -> "8") = True
+f3 _ _ = False
+
+a3 = (\(one of 1, 2) -> 3) 1
+a4 = (\(one of Left 0, Right 1) -> True) (Right 1)
+a5 = (\(one of (one of [1], [2, _]), (one of [3, _, _], [4, _, _, _])) -> True) [4, undefined, undefined, undefined]
+a6 = (\(one of 1, 2, 3) -> False) 3
+
+backtrack :: String
+backtrack = case (True, error "backtracking") of
+  (one of (True, _), (_, True))
+    | False -> error "inaccessible"
+  _ -> error "no backtracking"
\ No newline at end of file
diff --git a/testsuite/tests/deSugar/should_run/Or4.stderr b/testsuite/tests/deSugar/should_run/Or4.stderr
new file mode 100644
index 0000000000..58c96e12bf
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/Or4.stderr
@@ -0,0 +1,3 @@
+Or4: no backtracking
+CallStack (from HasCallStack):
+  error, called at Or4.hs:42:8 in main:Main
diff --git a/testsuite/tests/deSugar/should_run/Or4.stdout b/testsuite/tests/deSugar/should_run/Or4.stdout
new file mode 100644
index 0000000000..f3beed1d40
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/Or4.stdout
@@ -0,0 +1,10 @@
+True
+True
+True
+True
+True
+True
+True
+True
+True
+True
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index ce3185c213..7b909190e2 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -74,3 +74,5 @@ test('T19289', normal, compile_and_run, [''])
 test('T19680', normal, compile_and_run, [''])
 test('T19680A', normal, compile_and_run, [''])
 test('T20024', exit_code(1), compile_and_run, [''])
+
+test('Or4', exit_code(1), compile_and_run, [''])
diff --git a/testsuite/tests/parser/should_fail/Or1.hs b/testsuite/tests/parser/should_fail/Or1.hs
new file mode 100644
index 0000000000..f1cfb8058f
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or1.hs
@@ -0,0 +1,9 @@
+module Main where
+
+main = g 3 && h 1
+
+h y = case y of
+  (one of 2, 3) -> True
+
+g x = case x of
+  one of 4, 5 -> False
\ No newline at end of file
diff --git a/testsuite/tests/parser/should_fail/Or1.stderr b/testsuite/tests/parser/should_fail/Or1.stderr
new file mode 100644
index 0000000000..5f56a60860
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or1.stderr
@@ -0,0 +1,6 @@
+
+Or1.hs:6:4: error: [GHC-29847]
+    Illegal or-pattern: one of 2, 3
+    Suggested fix: Perhaps you intended to use OrPatterns
+
+Or1.hs:9:7: error: [GHC-58481] parse error on input ‘of’
diff --git a/testsuite/tests/parser/should_fail/Or2.hs b/testsuite/tests/parser/should_fail/Or2.hs
new file mode 100644
index 0000000000..ff29507a21
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or2.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE OrPatterns #-}
+
+module Main where
+
+main = case 3 of
+  (one of 4) -> False
\ No newline at end of file
diff --git a/testsuite/tests/parser/should_fail/Or2.stderr b/testsuite/tests/parser/should_fail/Or2.stderr
new file mode 100644
index 0000000000..6f52c69783
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or2.stderr
@@ -0,0 +1,3 @@
+
+Or2.hs:6:4: error: [GHC-96152]
+    An or-pattern needs at least two alternatives: one of 4
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 9dc87514c5..6d465f251b 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -215,3 +215,6 @@ test('T21843c', normal, compile_fail, [''])
 test('T21843d', normal, compile_fail, [''])
 test('T21843e', normal, compile_fail, [''])
 test('T21843f', normal, compile_fail, [''])
+
+test('Or1', normal, compile_fail, [''])
+test('Or2', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_fail/Or3.hs b/testsuite/tests/typecheck/should_fail/Or3.hs
new file mode 100644
index 0000000000..6a059c96a0
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/Or3.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE GADTs #-}
+
+module Main where
+
+data G a where
+  G1 :: Num a => G a
+  G2 :: Num a => G a
+  G3 :: Num a => G a
+
+bar :: G a -> a
+bar (one of G2, G1) = 3
+
+data GADT a where
+    IsInt1 :: GADT Int
+    IsInt2 :: GADT Int
+
+foo :: a -> GADT a -> a
+foo x (one of IsInt1 {}, IsInt2 {}) = x + 1
+
+f x = case x of
+  (one of Left a, Right a) -> a
+
+g x = case x of
+  (one of _, (one of _, x)) -> x
+
+main = print $ foo 3 IsInt1
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_fail/Or3.stderr b/testsuite/tests/typecheck/should_fail/Or3.stderr
new file mode 100644
index 0000000000..dcb862fd99
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/Or3.stderr
@@ -0,0 +1,14 @@
+
+Or3.hs:12:6: error: [GHC-81303]
+    An or-pattern may not bind (type) variables nor type class or equality constraints: one of G2,
+                                                                                               G1
+
+Or3.hs:19:8: error: [GHC-81303]
+    An or-pattern may not bind (type) variables nor type class or equality constraints: one of IsInt1 {},
+                                                                                               IsInt2 {}
+
+Or3.hs:22:4: error: [GHC-81303]
+    An or-pattern may not bind variables: one of Left a, Right a
+
+Or3.hs:25:15: error: [GHC-81303]
+    An or-pattern may not bind variables: one of _, x
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 61514e725b..2d2d0e4faf 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -665,6 +665,7 @@ test('MissingDefaultMethodBinding', normal, compile_fail, [''])
 test('T21447', normal, compile_fail, [''])
 test('T21530a', normal, compile_fail, [''])
 test('T21530b', normal, compile_fail, [''])
+test('Or3', normal, compile_fail, [''])
 test('T22570', normal, compile_fail, [''])
 test('T22645', normal, compile_fail, [''])
 test('T20666', normal, compile_fail, [''])