Implement Or Patterns (Proposal 0522)wip/or-pats

This commit introduces a language extension, `OrPatterns`, as described in proposal 0522.

It extends the syntax by the production
`pat -> (one of pat1, ..., patk)`.
The or-pattern `pat` succeeds iff one of the patterns `pat1`, ..., `patk` succeed, in this order.

Currently, or-patterns cannot bind variables. They are still of great use as they discourage the use of wildcard patterns in favour of writing out all "default" cases explicitly:

```
isIrrefutableHsPat pat = case pat of
  ...
  (one of WildPat{}, VarPat{}, LazyPat{})
      = True
  (one of PArrPat{}, ConPatIn{}, LitPat{}, NPat{}, NPlusKPat{}, ListPat{})
      = False
```

This makes code safer where data types are extended now and then - just like GHC's `Pat` in the example when adding the new `OrPat` constructor. This would be catched by `-fwarn-incomplete-patterns`, but not when a wildcard pattern was used.

- Update submodule haddock.

52 files changed, 718 insertions, 125 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2ad09bc7c6..c544b398a7 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3703,6 +3703,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 bc0b51457e..76d5aeb60e 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 qualified Data.List.NonEmpty as NE
 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 = EpAnn [AddEpAnn]
+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 (NE.toList pats)
 pprPat (TuplePat _ pats bx)
     -- Special-case unary boxed tuples so that they are pretty-printed as
     -- `MkSolo 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 a7e21d2458..f7c1aa9f00 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 5866243824..97cb1f0c10 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1210,6 +1210,9 @@ 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
+  -- Evidence binders in an OrPat currently aren't visible outside their
+  -- binding pattern. This makes error messages more specific.
+  OrPat _ _             -> []
   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 56fffd89a2..ff8621d330 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -227,7 +227,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 +239,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 +308,19 @@ 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 (shiftEqns [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)
+    ; 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 +442,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 +946,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 +1217,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/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
index a89f4e2643..7dbe208aca 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ b/compiler/GHC/HsToCore/Pmc/Check.hs
@@ -43,6 +43,13 @@ import Data.Coerce
 newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }
   deriving Functor
 
+-- | A 'CheckAction' representing a successful pattern-match.
+matchSucceeded :: CheckAction RedSets
+matchSucceeded = CA $ \inc -> -- succeed
+  pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }
+                   , cr_uncov = mempty
+                   , cr_approx = Precise }
+
 -- | Composes 'CheckAction's top-to-bottom:
 -- If a value falls through the resulting action, then it must fall through the
 -- first action and then through the second action.
@@ -91,12 +98,12 @@ throttle limit old@(MkNablas old_ds) new@(MkNablas new_ds)
   | length new_ds > max limit (length old_ds) = (Approximate, old)
   | otherwise                                 = (Precise,     new)
 
-checkSequence :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
+checkAlternatives :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
 -- The implementation is pretty similar to
 -- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@
-checkSequence act (t :| [])       = (:| []) <$> act t
-checkSequence act (t1 :| (t2:ts)) =
-  topToBottom (NE.<|) (act t1) (checkSequence act (t2:|ts))
+checkAlternatives act (t :| [])       = (:| []) <$> act t
+checkAlternatives act (t1 :| (t2:ts)) =
+  topToBottom (NE.<|) (act t1) (checkAlternatives act (t2:|ts))
 
 emptyRedSets :: RedSets
 -- Semigroup instance would be misleading!
@@ -148,33 +155,49 @@ checkGrd grd = CA $ \inc -> case grd of
                      , cr_uncov = uncov
                      , cr_approx = Precise }
 
-checkGrds :: [PmGrd] -> CheckAction RedSets
-checkGrds [] = CA $ \inc ->
-  pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }
-                   , cr_uncov = mempty
-                   , cr_approx = Precise }
-checkGrds (g:grds) = leftToRight merge (checkGrd g) (checkGrds grds)
+
+
+checkGrdDag :: GrdDag -> CheckAction RedSets
+checkGrdDag (GdOne g)     = checkGrd g
+checkGrdDag GdEnd         = matchSucceeded
+checkGrdDag (GdSeq dl dr) = leftToRight merge (checkGrdDag dl) (checkGrdDag dr)
+  where
+    -- Note that
+    --   * the incoming set of dr is the covered set of dl
+    --   * the covered set of dr is a subset of the incoming set of dr
+    --   * this is so that the covered set of dr is the covered set of the
+    --     entire sequence
+    -- Hence we merge by returning @rs_cov ri_r@ as the covered set.
+    merge ri_l ri_r =
+      RedSets { rs_cov   = rs_cov   ri_r
+              , rs_div   = rs_div   ri_l Semi.<> rs_div   ri_r
+              , rs_bangs = rs_bangs ri_l Semi.<> rs_bangs ri_r }
+checkGrdDag (GdAlt dt db) = topToBottom merge (checkGrdDag dt) (checkGrdDag db)
   where
-    merge ri_g ri_grds = -- This operation would /not/ form a Semigroup!
-      RedSets { rs_cov   = rs_cov ri_grds
-              , rs_div   = rs_div ri_g   Semi.<> rs_div ri_grds
-              , rs_bangs = rs_bangs ri_g Semi.<> rs_bangs ri_grds }
+    -- The intuition here: ri_b is disjoint with ri_t, because db only gets
+    -- fed the "leftover" uncovered set of dt. But for the GrdDag that follows
+    -- to the right of the GdAlt (say), we have to reunite the RedSets. Hence
+    -- component-wise merge.
+    merge ri_t ri_b =
+      RedSets { rs_cov   = rs_cov   ri_t Semi.<> rs_cov   ri_b
+              , rs_div   = rs_div   ri_t Semi.<> rs_div   ri_b
+              , rs_bangs = rs_bangs ri_t Semi.<> rs_bangs ri_b }
 
 checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
 checkMatchGroup (PmMatchGroup matches) =
-  PmMatchGroup <$> checkSequence checkMatch matches
+  PmMatchGroup <$> checkAlternatives checkMatch matches
 
 checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)
-checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) =
-  leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss)
+checkMatch (PmMatch { pm_pats = grds, pm_grhss = grhss }) =
+  leftToRight PmMatch (checkGrdDag grds) (checkGRHSs grhss)
 
 checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)
-checkGRHSs (PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss }) =
-  leftToRight PmGRHSs (checkGrds lcls) (checkSequence checkGRHS grhss)
+checkGRHSs (PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss }) =
+  leftToRight PmGRHSs (checkGrdDag lcls) (checkAlternatives checkGRHS grhss)
 
 checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)
-checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) =
-  flip PmGRHS rhs_info <$> checkGrds grds
+checkGRHS (PmGRHS { pg_grds = grds, pg_rhs = rhs_info }) =
+  flip PmGRHS rhs_info <$> checkGrdDag grds
 
 checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase
 -- See Note [Checking EmptyCase]
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 7958ef46db..35cd24a717 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -46,7 +46,6 @@ import GHC.Core.TyCo.Compare( eqType )
 import GHC.Core.Type
 import GHC.Data.Maybe
 import qualified GHC.LanguageExtensions as LangExt
-import GHC.Utils.Monad (concatMapM)
 import GHC.Types.SourceText (FractionalLit(..))
 import Control.Monad (zipWithM, replicateM)
 import Data.List (elemIndex)
@@ -56,9 +55,8 @@ import qualified Data.List.NonEmpty as NE
 -- import GHC.Driver.Ppr
 
 -- | Smart constructor that eliminates trivial lets
-mkPmLetVar :: Id -> Id -> [PmGrd]
-mkPmLetVar x y | x == y = []
-mkPmLetVar x y          = [PmLet x (Var y)]
+mkPmLetVar :: Id -> Id -> GrdDag
+mkPmLetVar x y = sequencePmGrds [ PmLet x (Var y) | x /= y ]
 
 -- | ADT constructor pattern => no existentials, no local constraints
 vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
@@ -66,25 +64,25 @@ vanillaConGrd scrut con arg_ids =
   PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)
         , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }
 
--- | Creates a '[PmGrd]' refining a match var of list type to a list,
--- where list fields are matched against the incoming tagged '[PmGrd]'s.
+-- | Creates a 'GrdDag' refining a match var of list type to a list,
+-- where list fields are matched against the incoming tagged 'GrdDag's.
 -- For example:
 --   @mkListGrds "a" "[(x, True <- x),(y, !y)]"@
 -- to
 --   @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@
 -- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match
 -- variable.
-mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
+mkListGrds :: Id -> [(Id, GrdDag)] -> DsM GrdDag
 -- See Note [Order of guards matters] for why we need to intertwine guards
 -- on list elements.
-mkListGrds a []                  = pure [vanillaConGrd a nilDataCon []]
+mkListGrds a []                  = pure (GdOne (vanillaConGrd a nilDataCon []))
 mkListGrds a ((x, head_grds):xs) = do
   b <- mkPmId (idType a)
   tail_grds <- mkListGrds b xs
-  pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds
+  pure $ vanillaConGrd a consDataCon [x, b] `consGrdDag` head_grds `gdSeq` tail_grds
 
--- | Create a '[PmGrd]' refining a match variable to a 'PmLit'.
-mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
+-- | Create a 'GrdDag' refining a match variable to a 'PmLit'.
+mkPmLitGrds :: Id -> PmLit -> DsM GrdDag
 mkPmLitGrds x (PmLit _ (PmLitString s)) = do
   -- We desugar String literals to list literals for better overlap reasoning.
   -- It's a little unfortunate we do this here rather than in
@@ -102,26 +100,25 @@ mkPmLitGrds x lit = do
                   , pm_con_tvs = []
                   , pm_con_dicts = []
                   , pm_con_args = [] }
-  pure [grd]
+  pure (GdOne grd)
 
--- | @desugarPat _ x pat@ transforms @pat@ into a '[PmGrd]', where
+-- | @desugarPat _ x pat@ transforms @pat@ into a 'GrdDag', where
 -- the variable representing the match is @x@.
-desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]
+desugarPat :: Id -> Pat GhcTc -> DsM GrdDag
 desugarPat x pat = case pat of
-  WildPat  _ty -> pure []
+  WildPat  _ty -> pure GdEnd
   VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)
   ParPat _ _ p _ -> desugarLPat x p
-  LazyPat _ _  -> pure [] -- like a wildcard
+  LazyPat _ _  -> pure GdEnd -- like a wildcard
   BangPat _ p@(L l p') ->
     -- Add the bang in front of the list, because it will happen before any
     -- nested stuff.
-    (PmBang x pm_loc :) <$> desugarLPat x p
+    consGrdDag (PmBang x pm_loc) <$> desugarLPat x p
       where pm_loc = Just (SrcInfo (L (locA l) (ppr p')))
 
   -- (x@pat)   ==>   Desugar pat with x as match var and handle impedance
   --                 mismatch with incoming match var
-  AsPat _ (L _ y) _ p -> (mkPmLetVar y x ++) <$> desugarLPat y p
-
+  AsPat _ (L _ y) _ p -> (mkPmLetVar y x `gdSeq`) <$> desugarLPat y p
   SigPat _ p _ty -> desugarLPat x p
 
   XPat ext -> case ext of
@@ -155,24 +152,20 @@ desugarPat x pat = case pat of
       | otherwise -> do
           (y, grds) <- desugarPatV p
           dsHsWrapper wrapper $ \wrap_rhs_y ->
-              pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-
-  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k
+            pure (PmLet y (wrap_rhs_y (Var x)) `consGrdDag` grds)  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k
   NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
     b <- mkPmId boolTy
     let grd_b = vanillaConGrd b trueDataCon []
     [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
     rhs_b <- dsSyntaxExpr ge    [Var x, ke1]
     rhs_n <- dsSyntaxExpr minus [Var x, ke2]
-    pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]
+    pure $ sequencePmGrds [PmLet b rhs_b, grd_b, PmLet n rhs_n]
 
   -- (fun -> pat)   ===>   let y = fun x, pat <- y where y is a match var of pat
   ViewPat _arg_ty lexpr pat -> do
     (y, grds) <- desugarLPatV pat
     fun <- dsLExpr lexpr
-    pure $ PmLet y (App fun (Var x)) : grds
-
-  -- list
+    pure $ consGrdDag (PmLet y (App fun (Var x))) grds  -- list
   ListPat _ ps ->
     desugarListPat x ps
 
@@ -236,41 +229,43 @@ desugarPat x pat = case pat of
   TuplePat _tys pats boxity -> do
     (vars, grdss) <- mapAndUnzipM desugarLPatV pats
     let tuple_con = tupleDataCon boxity (length vars)
-    pure $ vanillaConGrd x tuple_con vars : concat grdss
+    pure $ vanillaConGrd x tuple_con vars `consGrdDag` sequenceGrdDags grdss
+
+  OrPat _tys pats -> alternativesGrdDags <$> traverse (desugarLPat x) pats
 
   SumPat _ty p alt arity -> do
     (y, grds) <- desugarLPatV p
     let sum_con = sumDataCon alt arity
     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-    pure $ vanillaConGrd x sum_con [y] : grds
+    pure $ vanillaConGrd x sum_con [y] `consGrdDag` grds
 
   SplicePat {} -> panic "Check.desugarPat: SplicePat"
 
 -- | 'desugarPat', but also select and return a new match var.
-desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])
+desugarPatV :: Pat GhcTc -> DsM (Id, GrdDag)
 desugarPatV pat = do
   x <- selectMatchVar ManyTy pat
   grds <- desugarPat x pat
   pure (x, grds)
 
-desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]
+desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag
 desugarLPat x = desugarPat x . unLoc
 
 -- | 'desugarLPat', but also select and return a new match var.
-desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])
+desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag)
 desugarLPatV = desugarPatV . unLoc
 
 -- | @desugarListPat _ x [p1, ..., pn]@ is basically
 --   @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever
 -- constructing the 'ConPatOut's.
-desugarListPat :: Id -> [LPat GhcTc] -> DsM [PmGrd]
+desugarListPat :: Id -> [LPat GhcTc] -> DsM GrdDag
 desugarListPat x pats = do
   vars_and_grdss <- traverse desugarLPatV pats
   mkListGrds x vars_and_grdss
 
 -- | Desugar a constructor pattern
 desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]
-                 -> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]
+                 -> [EvVar] -> HsConPatDetails GhcTc -> DsM GrdDag
 desugarConPatOut x con univ_tys ex_tvs dicts = \case
     PrefixCon _ ps               -> go_field_pats (zip [0..] ps)
     InfixCon  p1 p2              -> go_field_pats (zip [0..] [p1,p2])
@@ -312,15 +307,15 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case
       let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids
 
       -- 2. guards from field selector patterns
-      let arg_grds = concat arg_grdss
+      let arg_grds = sequenceGrdDags arg_grdss
 
       -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)
-      pure (con_grd : arg_grds)
+      pure (con_grd `consGrdDag` arg_grds)
 
 desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
 -- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
 desugarPatBind loc var pat =
-  PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat
+  PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat
 
 desugarEmptyCase :: Id -> DsM PmEmptyCase
 desugarEmptyCase var = pure PmEmptyCase { pe_var = var }
@@ -337,10 +332,10 @@ desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
   dflags <- getDynFlags
   -- decideBangHood: See Note [Desugaring -XStrict matches in Pmc]
   let banged_pats = map (decideBangHood dflags) pats
-  pats'  <- concat <$> zipWithM desugarLPat vars banged_pats
+  pats'  <- sequenceGrdDags <$> zipWithM desugarLPat vars banged_pats
   grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss
   -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
-  return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }
+  return PmMatch { pm_pats = pats', pm_grhss = grhss' }
 
 desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
 desugarGRHSs match_loc pp_pats grhss = do
@@ -349,7 +344,7 @@ desugarGRHSs match_loc pp_pats grhss = do
               . expectJust "desugarGRHSs"
               . NE.nonEmpty
               $ grhssGRHSs grhss
-  return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' }
+  return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' }
 
 -- | Desugar a guarded right-hand side to a single 'GrdTree'
 desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)
@@ -362,11 +357,11 @@ desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do
   let rhs_info = case gs of
         []              -> L match_loc      pp_pats
         (L grd_loc _):_ -> L (locA grd_loc) (pp_pats <+> vbar <+> interpp'SP gs)
-  grds <- concatMapM (desugarGuard . unLoc) gs
-  pure PmGRHS { pg_grds = GrdVec grds, pg_rhs = SrcInfo rhs_info }
+  grdss <- traverse (desugarGuard . unLoc) gs
+  pure PmGRHS { pg_grds = sequenceGrdDags grdss, pg_rhs = SrcInfo rhs_info }
 
--- | Desugar a guard statement to a '[PmGrd]'
-desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]
+-- | Desugar a guard statement to a 'GrdDag'
+desugarGuard :: GuardStmt GhcTc -> DsM GrdDag
 desugarGuard guard = case guard of
   BodyStmt _   e _ _ -> desugarBoolGuard e
   LetStmt  _   binds -> desugarLocalBinds binds
@@ -377,22 +372,25 @@ desugarGuard guard = case guard of
   RecStmt         {} -> panic "desugarGuard RecStmt"
   ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt"
 
+sequenceGrdDagMapM :: Applicative f => (a -> f GrdDag) -> [a] -> f GrdDag
+sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as
+
 -- | Desugar local bindings to a bunch of 'PmLet' guards.
 -- Deals only with simple @let@ or @where@ bindings without any polymorphism,
 -- recursion, pattern bindings etc.
 -- See Note [Long-distance information for HsLocalBinds].
-desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]
+desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag
 desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
-  concatMapM (concatMapM go . bagToList) (map snd binds)
+  sequenceGrdDagMapM (sequenceGrdDagMapM go . bagToList) (map snd binds)
   where
-    go :: LHsBind GhcTc -> DsM [PmGrd]
+    go :: LHsBind GhcTc -> DsM GrdDag
     go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
       -- See Note [Long-distance information for HsLocalBinds] for why this
       -- pattern match is so very specific.
       | L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- mg_alts mg
       , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do
           core_rhs <- dsLExpr rhs
-          return [PmLet x core_rhs]
+          return (GdOne (PmLet x core_rhs))
     go (L _ (XHsBindsLR (AbsBinds
                           { abs_tvs = [], abs_ev_vars = []
                           , abs_exports=exports, abs_binds = binds }))) = do
@@ -408,14 +406,14 @@ desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
             | otherwise
             = Nothing
       let exps = mapMaybe go_export exports
-      bs <- concatMapM go (bagToList binds)
-      return (exps ++ bs)
-    go _ = return []
-desugarLocalBinds _binds = return []
+      bs <- sequenceGrdDagMapM go (bagToList binds)
+      return (sequencePmGrds exps `gdSeq` bs)
+    go _ = return GdEnd
+desugarLocalBinds _binds = return GdEnd
 
 -- | Desugar a pattern guard
 --   @pat <- e ==>  let x = e;  <guards for pat <- x>@
-desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]
+desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag
 desugarBind p e = dsLExpr e >>= \case
   Var y
     | Nothing <- isDataConId_maybe y
@@ -423,24 +421,24 @@ desugarBind p e = dsLExpr e >>= \case
     -> desugarLPat y p
   rhs -> do
     (x, grds) <- desugarLPatV p
-    pure (PmLet x rhs : grds)
+    pure (PmLet x rhs `consGrdDag` grds)
 
 -- | Desugar a boolean guard
 --   @e ==>  let x = e; True <- x@
-desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]
+desugarBoolGuard :: LHsExpr GhcTc -> DsM GrdDag
 desugarBoolGuard e
-  | isJust (isTrueLHsExpr e) = return []
+  | isJust (isTrueLHsExpr e) = return GdEnd
     -- The formal thing to do would be to generate (True <- True)
     -- but it is trivial to solve so instead we give back an empty
-    -- [PmGrd] for efficiency
+    -- GrdDag for efficiency
   | otherwise = dsLExpr e >>= \case
       Var y
         | Nothing <- isDataConId_maybe y
         -- Omit the let by matching on y
-        -> pure [vanillaConGrd y trueDataCon []]
+        -> pure (GdOne (vanillaConGrd y trueDataCon []))
       rhs -> do
         x <- mkPmId boolTy
-        pure [PmLet x rhs, vanillaConGrd x trueDataCon []]
+        pure $ sequencePmGrds [PmLet x rhs, vanillaConGrd x trueDataCon []]
 
 {- Note [Field match order for RecCon]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Pmc/Types.hs b/compiler/GHC/HsToCore/Pmc/Types.hs
index d3046e5812..3905f00921 100644
--- a/compiler/GHC/HsToCore/Pmc/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Types.hs
@@ -18,7 +18,9 @@ module GHC.HsToCore.Pmc.Types (
         -- * LYG syntax
 
         -- ** Guard language
-        SrcInfo(..), PmGrd(..), GrdVec(..),
+        SrcInfo(..), PmGrd(..), GrdDag(..),
+        consGrdDag, gdSeq, sequencePmGrds, sequenceGrdDags,
+        alternativesGrdDags,
 
         -- ** Guard tree language
         PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),
@@ -101,8 +103,50 @@ instance Outputable PmGrd where
 -- location.
 newtype SrcInfo = SrcInfo (Located SDoc)
 
--- | A sequence of 'PmGrd's.
-newtype GrdVec = GrdVec [PmGrd]
+-- | A Series-parallel graph of 'PmGrd's, so very nearly a guard tree, if
+-- it weren't for or-patterns/'GdAlt!
+-- The implicit "source" corresponds to "before the match" and the implicit
+-- "sink" corresponds to "after a successful match".
+--
+--   * 'GdEnd' is a 'GrdDag' that always matches.
+--   * 'GdOne' is a 'GrdDag' that matches iff its 'PmGrd' matches.
+--   * @'GdSeq' g1 g2@ corresponds to matching guards @g1@ and then @g2@
+--     if matching @g1@ succeeded.
+--     Example: The Haskell guard @| x > 1, x < 10 = ...@ will test @x > 1@
+--     before @x < 10@, failing if either test fails.
+--   * @'GdAlt' g1 g2@ is far less common than 'GdSeq' and corresponds to
+--     matching an or-pattern @(one of LT, EQ)@, succeeding if the
+--     match variable matches /either/ 'LT' or 'EQ'.
+--
+data GrdDag
+  = GdEnd
+  | GdOne !PmGrd
+  | GdSeq !GrdDag !GrdDag
+  | GdAlt !GrdDag !GrdDag
+
+-- | Sequentially compose a list of 'PmGrd's into a 'GrdDag'.
+sequencePmGrds :: [PmGrd] -> GrdDag
+sequencePmGrds = sequenceGrdDags . map GdOne
+
+-- | Sequentially compose a list of 'GrdDag's.
+sequenceGrdDags :: [GrdDag] -> GrdDag
+sequenceGrdDags xs = foldr gdSeq GdEnd xs
+
+-- | Sequentially compose a 'PmGrd' in front of a 'GrdDag'.
+consGrdDag :: PmGrd -> GrdDag -> GrdDag
+consGrdDag g d = gdSeq (GdOne g) d
+
+-- | Sequentially compose two 'GrdDag's. A smart constructor for `GdSeq` that
+-- eliminates `GdEnd`s.
+gdSeq :: GrdDag -> GrdDag -> GrdDag
+gdSeq g1    GdEnd = g1
+gdSeq GdEnd g2    = g2
+gdSeq g1    g2    = g1 `GdSeq` g2
+
+-- | Parallel composition of a list of 'GrdDag's.
+-- Needs a non-empty list as 'GdAlt' does not have a neutral element.
+alternativesGrdDags :: NonEmpty GrdDag -> GrdDag
+alternativesGrdDags xs = foldr1 GdAlt xs
 
 -- | A guard tree denoting 'MatchGroup'.
 newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p))
@@ -135,9 +179,15 @@ instance Outputable SrcInfo where
   ppr (SrcInfo (L s                   _)) = ppr s
 
 -- | Format LYG guards as @| True <- x, let x = 42, !z@
-instance Outputable GrdVec where
-  ppr (GrdVec [])     = empty
-  ppr (GrdVec (g:gs)) = fsep (char '|' <+> ppr g : map ((comma <+>) . ppr) gs)
+instance Outputable GrdDag where
+  ppr GdEnd = empty
+  ppr (GdOne g) = ppr g
+  ppr (GdSeq d1 d2) = ppr d1 <> comma <+> ppr d2
+  ppr d0@GdAlt{} = parens $ text "one of" <+> fsep (ppr d : map ((semi <+>) . ppr) ds)
+    where
+      d NE.:| ds = collect d0
+      collect (GdAlt d1 d2) = collect d1 Semi.<> collect d2
+      collect d = NE.singleton d
 
 -- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as
 -- @{ <first alt>; ...; <last alt> }@
@@ -232,7 +282,7 @@ instance Outputable a => Outputable (CheckResult a) where
 --
 
 -- | Used as tree payload pre-checking. The LYG guards to check.
-type Pre = GrdVec
+type Pre = GrdDag
 
 -- | Used as tree payload post-checking. The redundancy info we elaborated.
 type Post = RedSets
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index a64c8b74bc..bcb185f72c 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,
@@ -81,6 +81,7 @@ import GHC.Types.Tickish
 import GHC.Utils.Misc
 import GHC.Driver.Session
 import GHC.Driver.Ppr
+import GHC.Data.FastString
 import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Tc.Types.Evidence
@@ -906,31 +907,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 ac9976815f..9e822a9530 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -42,7 +42,7 @@ where
 import Control.Monad    ( unless, liftM, when, (<=<) )
 import GHC.Exts
 import Data.Maybe       ( maybeToList )
-import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.List.NonEmpty ( NonEmpty(..), (<|) )
 import qualified Data.List.NonEmpty as NE
 import qualified Prelude -- for happy-generated code
 
@@ -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,32 @@ texp :: { ECP }
                                 $1 >>= \ $1 ->
                                 pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
 
+
+        | 'one' 'of' vocurly orpats close
+                             {% do {
+                                    let srcSpan = comb2 $1 (reLoc (NE.last $4))
+                                    ; cs <- getCommentsFor srcSpan
+                                    ; let pat' = OrPat (EpAnn (spanAsAnchor srcSpan) [mj AnnOne $1, mj AnnOf $2] cs) $4
+                                    ; let pat = sL (noAnnSrcSpan srcSpan) pat'
+                                    ; 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 :: { NonEmpty (LPat GhcPs) }
+        : tpat %shift      { NE.singleton $1 }
+
+        | tpat ',' orpats  {% do {
+                                  a <- addTrailingCommaA $1 (getLoc $2)
+                                  ; return (a<|$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 +3357,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] }
@@ -3812,8 +3852,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'
+-- and 'anyclass', whose treatment differs depending on context
 special_id :: { Located FastString }
 special_id
         : 'as'                  { sL1 $1 (fsLit "as") }
@@ -3826,6 +3866,7 @@ special_id
         | 'ccall'               { sL1 $1 (fsLit "ccall") }
         | 'capi'                { sL1 $1 (fsLit "capi") }
         | 'prim'                { sL1 $1 (fsLit "prim") }
+        | 'one'                 { sL1 $1 (fsLit "one") }
         | 'javascript'          { sL1 $1 (fsLit "javascript") }
         -- See Note [%shift: special_id -> 'group']
         | 'group' %shift        { sL1 $1 (fsLit "group") }
@@ -4167,6 +4208,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/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f4e1a06198..c0eda51bbc 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -258,6 +258,7 @@ data AnnKeywordId
     | AnnNewtype
     | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf
+    | AnnOne
     | AnnOpen    -- ^ '{-\# DEPRECATED' etc. Opening of pragmas where
                  -- the capitalisation of the string can be changed by
                  -- the user. The actual text used is stored in a
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 380a30ca78..cb2b361f58 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -755,6 +755,7 @@ data Token
   | ITjavascriptcallconv
   | ITmdo (Maybe FastString)
   | ITfamily
+  | ITone
   | ITrole
   | ITgroup
   | ITby
@@ -998,6 +999,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 ),
@@ -2903,6 +2905,7 @@ data ExtBits
   | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]
   | OverloadedRecordDotBit
   | OverloadedRecordUpdateBit
+  | OrPatternsBit
 
   -- Flags that are updated once parsing starts
   | InRulePragBit
@@ -2982,6 +2985,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 f505e9b59d..2b2230c5ac 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DataKinds #-}
 
+
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -107,6 +108,7 @@ module GHC.Parser.PostProcess (
         DisambECP(..),
         ecpFromExp,
         ecpFromCmd,
+        ecpFromPat,
         PatBuilder,
 
         -- Type/datacon ambiguity resolution
@@ -164,7 +166,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,30 +1160,34 @@ 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
       , pat_args = PrefixCon tyargs args
       }
+  | null args && null tyargs = return $ L l (VarPat noExtField (L ln c))
   | not (null tyargs) =
       patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs
-  | (not (null args) && patIsRec c) = do
+  | 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 = do
+      details <- fromParseContext <$> askParseContext
+      patFail (locA l) (PsErrInPat e details)
+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 +1196,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 +1232,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 +1466,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 +1511,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 +1661,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 +1746,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)
@@ -1821,6 +1841,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
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 661c271fb9..5368f60ec5 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -560,6 +560,7 @@ isOkNoBindPattern (L _ pat) =
           AsPat _ _ _ lp  -> lpatternContainsSplice lp
           ParPat _ _ lp _ -> lpatternContainsSplice lp
           ViewPat _ _ lp -> lpatternContainsSplice lp
+          OrPat _ lps -> any lpatternContainsSplice lps
           SigPat _ lp _  -> lpatternContainsSplice lp
           ListPat _ lps  -> any lpatternContainsSplice lps
           TuplePat _ lps _ -> any lpatternContainsSplice lps
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 47e6217f56..7d795fef59 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -2274,6 +2274,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 ccfb77fbde..2879eefaa1 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -608,6 +608,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)
@@ -1003,4 +1007,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 a9b9718433..08c50c80a9 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1163,6 +1163,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 (type) 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"
@@ -1692,6 +1695,8 @@ instance Diagnostic TcRnMessage where
       -> if isError then ErrorWithoutFlag else WarningWithoutFlag
     TcRnInterfaceLookupError{}
       -> ErrorWithoutFlag
+    TcRnOrPatBindsVariables{}
+      -> ErrorWithoutFlag
     TcRnUnsatisfiedMinimalDef{}
       -> WarningWithFlag (Opt_WarnMissingMethods)
     TcRnMisplacedInstSig{}
@@ -2130,6 +2135,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 108eba5ab0..4e3b1c0eb7 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2553,6 +2553,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 (type) 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 28b9891b91..b3417ffe98 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -5,6 +5,8 @@
 {-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -72,6 +74,7 @@ import Control.Arrow  ( second )
 import Control.Monad
 import GHC.Data.FastString
 import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty (..))
 
 import GHC.Data.List.SetOps ( getNth )
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
@@ -359,6 +362,17 @@ tc_lpats tys penv pats
                penv
                (zipEqual "tc_lpats" pats tys)
 
+-- NB: do not require tys and pats to have the same length
+tc_lpats_ne :: NonEmpty (Scaled ExpSigmaTypeFRR)
+            -> Checker (NonEmpty (LPat GhcRn)) (NonEmpty (LPat GhcTc))
+tc_lpats_ne (ty:|tys) penv (pat:|pats) ti = do
+  err_ctxt <- getErrCtxt
+  (p, (ps, res)) <-
+      tc_lpat ty penv pat $
+      setErrCtxt err_ctxt $
+      tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p) penv (zip pats tys) ti
+  return (p:|ps, res)
+
 --------------------
 -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
 checkManyPattern :: Scaled a -> TcM HsWrapper
@@ -387,6 +401,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 _ pats -> do -- or-patterns with variables are rejected later, after zonking
+    { (pats', res) <- tc_lpats_ne (NE.repeat pat_ty) penv pats thing_inside
+    ; pat_ty <- expTypeToType (scaledThing pat_ty)
+    ; return (OrPat pat_ty 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 f9ab10b6d0..cfe666f0da 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,7 +92,9 @@ import GHC.Data.Bag
 
 import Control.Monad
 import Data.List  ( partition )
+import qualified Data.List.NonEmpty as NE
 import Control.Arrow ( second )
+import Data.List.NonEmpty (NonEmpty(..))
 
 {- *********************************************************************
 *                                                                      *
@@ -1342,6 +1345,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') <- zonkPatsNE env pats
+        ; checkNoVarsBound (NE.toList 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
         ; (env', pat') <- zonkPat env pat
@@ -1446,6 +1461,11 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
                              ; (env', pats') <- zonkPats env1 pats
                              ; return (env', pat':pats') }
 
+zonkPatsNE :: ZonkEnv -> NonEmpty (LPat GhcTc) -> TcM (ZonkEnv, NonEmpty (LPat GhcTc))
+zonkPatsNE env (pat:|pats) = do { (env1, pat') <- zonkPat env pat
+                             ; (env', pats') <- zonkPats env1 pats
+                             ; return (env', pat':|pats') }
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 9d3fe30084..d2aa499d62 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
@@ -469,7 +471,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma"             = 35827
   GhcDiagnosticCode "TcRnSpecialiseNotVisible"                      = 85337
   GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl"                   = 50649
-
+  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/docs/users_guide/exts/or_patterns.rst b/docs/users_guide/exts/or_patterns.rst
new file mode 100644
index 0000000000..8f500bad87
--- /dev/null
+++ b/docs/users_guide/exts/or_patterns.rst
@@ -0,0 +1,102 @@
+.. _or-patterns:
+
+Or-Patterns
+-------------
+
+.. extension:: OrPatterns
+    :shortdesc: Enable or-patterns.
+
+    :since: 9.8.1
+
+    Allow use of or-pattern syntax.
+
+Or-patterns are enabled by the language extension :extension:`OrPatterns`.
+
+They allow condensing multiple patterns into a single one. Suppose you had some sum type: ::
+
+    data Sweet = Cupcake | Liquorice | Cookie | Raisins
+    
+    tasty Cupcake = True
+    tasty Cookie = True
+    tasty _ = False
+
+All well and good, but what if we add another constructor to our type, like ``Cheesecake``?
+Because of the wildcard pattern we used when defining ``tasty``, the compiler doesn't warn us that the pattern match is incomplete,
+resulting in cheesecake incorrectly being characterised as untasty. What a shame!
+
+So if we want the compiler to aid us, we should have written out all cases explicitly, vertically bloating the code.
+Now or-patterns come in quite handy: With ``-XOrPatterns``, we can write: ::
+
+  tasty (one of Cupcake, Cookie) = True
+  tasty (one of Liquorice, Raisins) = False
+  
+If we extend ``Sweet`` by another constructor, we'll now get a warning about a non-exhaustive pattern match – given we compile with ``-Wincomplete-patterns``.
+
+While this may seem like a pointless example, it isn't: there are lots of places in GHC where constructor pattern matches either use a closing wildcard, or where all patterns are explicitly matched at the expense of code duplication. Just look at `Pat.hs <https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Hs/Pat.hs>`_.
+
+
+Specification
+~~~~~~~~~~~~~
+
+An or-pattern looks like this: ::
+
+  (one of pat_1, ..., pat_n)
+
+where ``pat_1``, ..., ``pat_n`` are patterns themselves. Or-Patterns are ordinary patterns and can be used wherever other patterns can be used.
+
+The result of matching a value ``x`` against this pattern is:
+
+- the result of matching ``x`` against ``pat_1`` if it is not a failure
+
+- the result of matching ``x`` against ``(one of pat_2, ..., pat_n)`` otherwise.
+
+
+The current main restriction on or-patterns is that **they may not bind any variables or constraints**. This prohibits code like ::
+
+  value :: Either a a -> a
+  value (one of Left x, Right x) = x -- binds a variable
+
+or ::
+
+  data G a where
+    G1 :: Num a => G a
+    G2 :: Num a => G a
+
+  bar :: G a -> a
+  bar (one of G1, G2) = 3 -- induces `Num a`
+
+  data GADT a where
+    IsInt1 :: GADT Int
+    IsInt2 :: GADT Int
+
+  foo :: a -> GADT a -> a
+  foo x (one of IsInt1 {}, IsInt2 {}) = x + 1 -- induces `a ~ Int`
+
+This is so because it is hard to specify good and correct static semantics for such or-patterns, but this could still be done sometime in the future.
+
+
+So what *can* or-patterns do?
+
+Apart from reducing code size and duplication, they interact with all forms of existing patterns, like view patterns and pattern synonyms: ::
+
+  f :: (Eq a, Show a) => a -> a -> Bool
+  f a (one of (== a) -> True, show -> "yes") = True
+  f _ _ = False
+
+  small (one of abs -> (one of 0, 1, 2), 3) = True -- -3 is not small
+  small _ = False
+
+  type Coll a = Either [a] (Set a)
+  pattern None <- (one of (Left []), Right (toList -> []))
+
+  empty None = False
+  empty _ = True
+
+Or-patterns do not employ backtracking when given guarded right hand sides, i.e. when one alternative of the or-pattern matches, the others are not tried when the guard fails. The following code yields ``"no backtracking"``: ::
+
+  case (True, error "backtracking") of
+    (one of (True, _), (_, True)) | False -> error "inaccessible"
+    _ -> error "no backtracking"
+
+
+(The exact syntax and semantics of or-patterns are found `here <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0522-or-patterns.rst#22static-semantics-of-or-pattern-matching>`_.)
\ No newline at end of file
diff --git a/docs/users_guide/exts/patterns.rst b/docs/users_guide/exts/patterns.rst
index f55583fb0b..dce0f9511f 100644
--- a/docs/users_guide/exts/patterns.rst
+++ b/docs/users_guide/exts/patterns.rst
@@ -10,3 +10,4 @@ Patterns
     view_patterns
     nk_patterns
     pattern_synonyms
+    or_patterns
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/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 3c07aa5679..f9e66d665e 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -37,7 +37,8 @@ check title expected got
 -- See Note [Adding a language extension] in compiler/GHC/Driver/Session.hs.
 expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions =
-    [ "TypeAbstractions"
+    [ "TypeAbstractions",
+      "OrPatterns"
     ]
 
 expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/parser/should_fail/Or1.hs b/testsuite/tests/parser/should_fail/Or1.hs
new file mode 100644
index 0000000000..6aceae974c
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or1.hs
@@ -0,0 +1,6 @@
+module Main where
+
+main = print $ h 1
+
+h one = case one of
+  (one of 2, 3) -> True
\ 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..96b83e9b36
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or1.stderr
@@ -0,0 +1,4 @@
+
+Or1.hs:6:4: error: [GHC-29847]
+    Illegal or-pattern: one of 2, 3
+    Suggested fix: Perhaps you intended to use OrPatterns
diff --git a/testsuite/tests/parser/should_fail/Or2.hs b/testsuite/tests/parser/should_fail/Or2.hs
new file mode 100644
index 0000000000..4e2d6ff62a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or2.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OrPatterns, PatternSynonyms #-}
+
+module Main where
+
+main = case 3 of
+  (one of 4) -> False
+
+g x = case x of
+  one of 4, 5 -> False
diff --git a/testsuite/tests/parser/should_fail/Or2.stderr b/testsuite/tests/parser/should_fail/Or2.stderr
new file mode 100644
index 0000000000..de7d47e000
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or2.stderr
@@ -0,0 +1,5 @@
+
+Or2.hs:6:4: error: [GHC-96152]
+    An or-pattern needs at least two alternatives: one of 4
+
+Or2.hs:9:7: error: [GHC-58481] parse error on input ‘of’
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/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 94c044b3d8..3115e0ae7e 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -101,6 +101,7 @@ test('pmc006', [], compile, [overlapping_incomplete])
 test('pmc007', [], compile, [overlapping_incomplete])
 test('pmc008', [], compile, [overlapping_incomplete])
 test('pmc009', [], compile, [overlapping_incomplete+'-package ghc'])
+test('pmcOrPats', [], compile, [overlapping_incomplete])
 test('T11245', [], compile, [overlapping_incomplete])
 test('T11336b', [], compile, [overlapping_incomplete])
 test('T12949', [],  compile, [overlapping_incomplete])
diff --git a/testsuite/tests/pmcheck/should_compile/pmcOrPats.hs b/testsuite/tests/pmcheck/should_compile/pmcOrPats.hs
new file mode 100644
index 0000000000..ff9df1b4a6
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/pmcOrPats.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+{-# LANGUAGE OrPatterns #-}
+
+data T = A | B
+data U = V | W
+
+g :: T -> U -> Int
+g (one of A,B) V = 0
+g B (one of V,W) = 1
+
+h A (one of _,W) B = 0
+h B (one of V,_) B = 1
+h (one of A,B) _ B = 2
+
+z (one of 1,2,1) = 0
+z (one of 3,2) = 1
+z 1 = 2
+
+main = print 2
\ No newline at end of file
diff --git a/testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr b/testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
new file mode 100644
index 0000000000..04f34268cd
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
@@ -0,0 +1,25 @@
+
+pmcOrPats.hs:8:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘g’: Patterns of type ‘T’, ‘U’ not matched: A W
+
+pmcOrPats.hs:11:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘h’:
+        Patterns of type ‘T’, ‘U’, ‘T’ not matched:
+            A _ A
+            B V A
+            B W A
+
+pmcOrPats.hs:13:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In an equation for ‘h’: h (one of A, B) _ B = ...
+
+pmcOrPats.hs:15:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘z’:
+        Patterns of type ‘a’ not matched: p where p is not one of {3, 1, 2}
+
+pmcOrPats.hs:17:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In an equation for ‘z’: z 1 = ...
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index de88dea3f0..792a8787b1 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -729,6 +729,11 @@ PprCommentPlacement2:
 	$(CHECK_PPR)   $(LIBDIR) PprCommentPlacement2.hs
 	$(CHECK_EXACT) $(LIBDIR) PprCommentPlacement2.hs
 
+.PHONY: PprOrPat
+PprOrPat:
+	$(CHECK_PPR)   $(LIBDIR) PprOrPat.hs
+	$(CHECK_EXACT) $(LIBDIR) PprOrPat.hs
+
 .PHONY: Test20243
 Test20243:
 	$(CHECK_PPR)   $(LIBDIR) Test20243.hs
diff --git a/testsuite/tests/printer/PprOrPat.hs b/testsuite/tests/printer/PprOrPat.hs
new file mode 100644
index 0000000000..3ddc01f52c
--- /dev/null
+++ b/testsuite/tests/printer/PprOrPat.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Main where
+
+a = case [1] of
+  [1,2,3] -> True
+  ( one   {- 01-}  of
+         {- 12  -}  [4, 5] ,   [6,7 {- lol -}] {-test-}
+      )   ->  False
+
+pattern A <- (one of ({-hmm-} reverse -> {-e-}( {-f-} one  of [2,1],  0:_ )),  id  ->  []) {-123-}
+b = case [1,2] of A -> True
+
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 619a781810..f559894707 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -171,6 +171,7 @@ test('PprT13747', [ignore_stderr, req_ppr_deps], makefile_test, ['PprT13747'])
 test('PprBracesSemiDataDecl', [ignore_stderr, req_ppr_deps], makefile_test, ['PprBracesSemiDataDecl'])
 test('PprUnicodeSyntax', [ignore_stderr, req_ppr_deps], makefile_test, ['PprUnicodeSyntax'])
 test('PprCommentPlacement2', [ignore_stderr, req_ppr_deps], makefile_test, ['PprCommentPlacement2'])
+test('PprOrPat', [ignore_stderr, req_ppr_deps], makefile_test, ['PprOrPat'])
 
 test('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243'])
 test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
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 bf03352115..d37ff0c010 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -664,6 +664,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, [''])   # To become compile_fail after migration period (see #22912)
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index a569b803d4..98e78a2826 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -63,6 +63,7 @@ import Data.Functor.Const
 import qualified Data.Set as Set
 import Data.Typeable
 import Data.List ( partition, sort, sortBy)
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe ( isJust, mapMaybe )
 import Data.Void
 
@@ -4558,6 +4559,7 @@ instance ExactPrint (Pat GhcPs) where
   getAnnotationEntry (NPat an _ _ _)          = fromAnn an
   getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
   getAnnotationEntry (SigPat an _ _)          = fromAnn an
+  getAnnotationEntry (OrPat an _)             = fromAnn an
 
   setAnnotationAnchor a@(WildPat _)              _ _s = a
   setAnnotationAnchor a@(VarPat _ _)             _ _s = a
@@ -4575,6 +4577,7 @@ instance ExactPrint (Pat GhcPs) where
   setAnnotationAnchor (NPat an a b c)          anc cs = (NPat (setAnchorEpa an anc cs) a b c)
   setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e)
   setAnnotationAnchor (SigPat an a b)          anc cs = (SigPat (setAnchorEpa an anc cs) a b)
+  setAnnotationAnchor (OrPat an a)             anc cs = (OrPat (setAnchorEpa an anc cs) a)
 
   exact (WildPat w) = do
     anchor <- getAnchorU
@@ -4664,6 +4667,12 @@ instance ExactPrint (Pat GhcPs) where
     sig' <- markAnnotated sig
     return (SigPat an0 pat' sig')
 
+  exact (OrPat an pats) = do
+    an0 <- markEpAnnL an lidl AnnOne
+    an1 <- markEpAnnL an0 lidl AnnOf
+    pats' <- markAnnotated (NE.toList pats)
+    return (OrPat an1 (NE.fromList pats'))
+
 -- ---------------------------------------------------------------------
 
 instance ExactPrint (HsPatSigType GhcPs) where
diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs
index d3a7df6c2a..1ba37d05dd 100644
--- a/utils/check-exact/Lookup.hs
+++ b/utils/check-exact/Lookup.hs
@@ -76,6 +76,7 @@ keywordToString kw =
       AnnModule       -> "module"
       AnnNewtype      -> "newtype"
       AnnOf           -> "of"
+      AnnOne          -> "one"
       AnnOpenB        -> "(|"
       AnnOpenBU       ->  "⦇"
       AnnOpenC        -> "{"
diff --git a/utils/haddock b/utils/haddock
-Subproject 519a95998b09a2c9c7a42c3a0cf2ca0c4358bb4
+Subproject f9ddb2eba372cf3c2446d61658985ae5d3dc19d