From 38757c305e96a1db93cc48a3d7bea4277433f97f Mon Sep 17 00:00:00 2001
From: David Knothe <dknothe314@me.com>
Date: Tue, 25 Oct 2022 09:18:26 +0200
Subject: [PATCH] Implement Or Patterns (#22596)
This commit introduces a new language extension, `-XOrPatterns`, as described in
GHC Proposal 522.
An or-pattern `pat1; ...; patk` succeeds iff one of the patterns `pat1`, ...,
`patk` succeed, in this order.
See also the summary `Note [Implmentation of OrPatterns]`.
Co-Authored-By: Sebastian Graf <sgraf1337@gmail.com>
---
compiler/GHC/Builtin/Names/TH.hs | 10 +-
compiler/GHC/Driver/Flags.hs | 1 +
compiler/GHC/Hs/Pat.hs | 135 +++++++++++++++++-
compiler/GHC/Hs/Syn/Type.hs | 1 +
compiler/GHC/Hs/Utils.hs | 4 +
compiler/GHC/HsToCore/Expr.hs | 23 +--
compiler/GHC/HsToCore/ListComp.hs | 2 +-
compiler/GHC/HsToCore/Match.hs | 58 ++++++--
compiler/GHC/HsToCore/Pmc/Check.hs | 93 ++++++++----
compiler/GHC/HsToCore/Pmc/Desugar.hs | 119 ++++++++-------
compiler/GHC/HsToCore/Pmc/Types.hs | 65 ++++++++-
compiler/GHC/HsToCore/Quote.hs | 17 +++
compiler/GHC/HsToCore/Utils.hs | 34 +++--
compiler/GHC/Iface/Ext/Ast.hs | 2 +
compiler/GHC/Parser.y | 72 +++++++++-
compiler/GHC/Parser/Errors/Ppr.hs | 12 ++
compiler/GHC/Parser/Errors/Types.hs | 6 +
compiler/GHC/Parser/Lexer.x | 2 +
compiler/GHC/Parser/PostProcess.hs | 13 ++
compiler/GHC/Rename/Bind.hs | 1 +
compiler/GHC/Rename/Expr.hs | 88 +++++++-----
compiler/GHC/Rename/Pat.hs | 14 +-
compiler/GHC/Tc/Errors/Ppr.hs | 7 +
compiler/GHC/Tc/Errors/Types.hs | 12 +-
compiler/GHC/Tc/Gen/Pat.hs | 10 ++
compiler/GHC/Tc/TyCl/PatSyn.hs | 1 +
compiler/GHC/Tc/Zonk/Type.hs | 10 +-
compiler/GHC/ThToHs.hs | 6 +-
compiler/GHC/Types/Error/Codes.hs | 3 +
compiler/GHC/Utils/Outputable.hs | 8 +-
compiler/Language/Haskell/Syntax/Extension.hs | 3 +-
compiler/Language/Haskell/Syntax/Pat.hs | 5 +
docs/users_guide/exts/or_patterns.rst | 122 ++++++++++++++++
docs/users_guide/exts/patterns.rst | 1 +
libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs | 2 +
.../src/GHC/Internal/LanguageExtensions.hs | 1 +
.../ghc-internal/src/GHC/Internal/TH/Lib.hs | 3 +
.../src/GHC/Internal/TH/Syntax.hs | 1 +
testsuite/tests/ado/OrPatStrictness.hs | 22 +++
testsuite/tests/ado/OrPatStrictness.stderr | 2 +
testsuite/tests/ado/OrPatStrictness.stdout | 1 +
testsuite/tests/ado/all.T | 1 +
testsuite/tests/deSugar/should_run/Or5.hs | 57 ++++++++
testsuite/tests/deSugar/should_run/Or5.stderr | 8 ++
testsuite/tests/deSugar/should_run/Or5.stdout | 14 ++
testsuite/tests/deSugar/should_run/all.T | 2 +
testsuite/tests/driver/T4437.hs | 2 +-
.../template-haskell-exports.stdout | 8 +-
testsuite/tests/parser/should_fail/Or1.hs | 4 +
testsuite/tests/parser/should_fail/Or1.stderr | 5 +
.../parser/should_fail/OrPatInExprErr.hs | 5 +
.../parser/should_fail/OrPatInExprErr.stderr | 3 +
testsuite/tests/parser/should_fail/all.T | 2 +
testsuite/tests/pmcheck/should_compile/all.T | 1 +
.../tests/pmcheck/should_compile/pmcOrPats.hs | 23 +++
.../pmcheck/should_compile/pmcOrPats.stderr | 45 ++++++
testsuite/tests/printer/Makefile | 5 +
testsuite/tests/printer/PprOrPat.hs | 15 ++
testsuite/tests/printer/all.T | 1 +
testsuite/tests/rename/should_fail/Or3.hs | 12 ++
testsuite/tests/rename/should_fail/Or3.stderr | 9 ++
testsuite/tests/rename/should_fail/all.T | 1 +
testsuite/tests/typecheck/should_fail/Or4.hs | 18 +++
.../tests/typecheck/should_fail/Or4.stderr | 18 +++
testsuite/tests/typecheck/should_fail/all.T | 1 +
utils/check-exact/ExactPrint.hs | 5 +
66 files changed, 1074 insertions(+), 183 deletions(-)
create mode 100644 docs/users_guide/exts/or_patterns.rst
create mode 100644 testsuite/tests/ado/OrPatStrictness.hs
create mode 100644 testsuite/tests/ado/OrPatStrictness.stderr
create mode 100644 testsuite/tests/ado/OrPatStrictness.stdout
create mode 100644 testsuite/tests/deSugar/should_run/Or5.hs
create mode 100644 testsuite/tests/deSugar/should_run/Or5.stderr
create mode 100644 testsuite/tests/deSugar/should_run/Or5.stdout
create mode 100644 testsuite/tests/parser/should_fail/Or1.hs
create mode 100644 testsuite/tests/parser/should_fail/Or1.stderr
create mode 100644 testsuite/tests/parser/should_fail/OrPatInExprErr.hs
create mode 100644 testsuite/tests/parser/should_fail/OrPatInExprErr.stderr
create mode 100644 testsuite/tests/pmcheck/should_compile/pmcOrPats.hs
create mode 100644 testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
create mode 100644 testsuite/tests/printer/PprOrPat.hs
create mode 100644 testsuite/tests/rename/should_fail/Or3.hs
create mode 100644 testsuite/tests/rename/should_fail/Or3.stderr
create mode 100644 testsuite/tests/typecheck/should_fail/Or4.hs
create mode 100644 testsuite/tests/typecheck/should_fail/Or4.stderr
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index acf2e018b699..9f973ac86785 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -47,7 +47,7 @@ templateHaskellNames = [
litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
conPName, tildePName, bangPName, infixPName,
asPName, wildPName, recPName, listPName, sigPName, viewPName,
- typePName, invisPName,
+ typePName, invisPName, orPName,
-- FieldPat
fieldPatName,
-- Match
@@ -277,7 +277,7 @@ charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey
-- data Pat = ...
litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
- sigPName, viewPName, typePName, invisPName :: Name
+ sigPName, viewPName, typePName, invisPName, orPName :: Name
litPName = libFun (fsLit "litP") litPIdKey
varPName = libFun (fsLit "varP") varPIdKey
tupPName = libFun (fsLit "tupP") tupPIdKey
@@ -293,8 +293,9 @@ recPName = libFun (fsLit "recP") recPIdKey
listPName = libFun (fsLit "listP") listPIdKey
sigPName = libFun (fsLit "sigP") sigPIdKey
viewPName = libFun (fsLit "viewP") viewPIdKey
+orPName = libFun (fsLit "orP") orPIdKey
typePName = libFun (fsLit "typeP") typePIdKey
-invisPName = libFun (fsLit "invisP") invisPIdKey
+invisPName = libFun (fsLit "invisP") invisPIdKey
-- type FieldPat = ...
fieldPatName :: Name
@@ -841,7 +842,7 @@ liftStringIdKey = mkPreludeMiscIdUnique 230
-- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
- listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey :: Unique
+ listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 240
varPIdKey = mkPreludeMiscIdUnique 241
tupPIdKey = mkPreludeMiscIdUnique 242
@@ -859,6 +860,7 @@ sigPIdKey = mkPreludeMiscIdUnique 253
viewPIdKey = mkPreludeMiscIdUnique 254
typePIdKey = mkPreludeMiscIdUnique 255
invisPIdKey = mkPreludeMiscIdUnique 256
+orPIdKey = mkPreludeMiscIdUnique 257
-- type FieldPat = ...
fieldPatIdKey :: Unique
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index f2cbc92a838d..4a83961cd317 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -151,6 +151,7 @@ extensionName = \case
LangExt.OverloadedStrings -> "OverloadedStrings"
LangExt.OverloadedLists -> "OverloadedLists"
LangExt.NumDecimals -> "NumDecimals"
+ LangExt.OrPatterns -> "OrPatterns"
LangExt.DisambiguateRecordFields -> "DisambiguateRecordFields"
LangExt.RecordWildCards -> "RecordWildCards"
LangExt.NamedFieldPuns -> "NamedFieldPuns"
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 6a816f2a15cd..2b4603222adb 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -79,12 +79,14 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Outputable
+import GHC.Utils.Monad
import GHC.Core.Type
import GHC.Types.SrcLoc
import GHC.Data.Bag -- collect ev vars from pats
import GHC.Data.Maybe
import GHC.Types.Name (Name, dataName)
import Data.Data
+import qualified Data.List.NonEmpty as NE
import Data.Functor.Identity
@@ -124,6 +126,10 @@ type instance XTuplePat GhcPs = [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 = EpAnnSumPat
type instance XSumPat GhcRn = NoExtField
type instance XSumPat GhcTc = [Type]
@@ -433,6 +439,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) = pprWithSemis ppr (NE.toList pats)
pprPat (TuplePat _ pats bx)
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `MkSolo x`, not `(x)`
@@ -682,7 +689,8 @@ isIrrefutableHsPatHelperM is_strict isConLikeIrr pat = go (unLoc pat)
go (AsPat _ _ pat) = goL pat
go (ViewPat _ _ pat) = goL pat
go (SigPat _ pat _) = goL pat
- go (TuplePat _ pats _) = do { bs <- mapM goL pats; return $ and bs }
+ go (TuplePat _ pats _) = allM goL pats
+ go (OrPat _ pats) = anyM goL pats
go (SumPat {}) = return False
-- See Note [Unboxed sum patterns aren't irrefutable]
go (ListPat {}) = return False
@@ -764,6 +772,7 @@ isBoringHsPat = goL
-- A pattern match on a GADT constructor can introduce
-- type-level information (for example, T18572).
-> False
+ OrPat _ pats -> all goL pats
LitPat {} -> True
NPat {} -> True
NPlusKPat {} -> True
@@ -854,8 +863,130 @@ Here we *do not* want to emit a pattern-match warning on the first line for the
incomplete pattern-match, as incompleteness inside do-notation is handled
using MonadFail. However, we still want to propagate the fact that x is headed
by the 'Just' constructor, to avoid a pattern-match warning on the last line.
+
+Note [Implementation of OrPatterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note describes the implementation of the extension -XOrPatterns.
+
+* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0522-or-patterns.rst
+* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/522 and others
+
+Parser
+------
+We parse an or-pattern `pat_1; ...; pat_k` into `OrPat [pat_1, ..., pat_k]`,
+where `OrPat` is a constructor of `Pat` in Language.Haskell.Syntax.Pat.
+We occasionally refer to any of the `pat_k` as "pattern alternatives" below.
+The changes to the parser are as outlined in Section 8.1 of the proposal.
+The main productions are
+
+ orpats -> exp | exp ';' orpats
+ aexp2 -> '(' orpats ')'
+ pat -> orpats
+
+Renamer and typechecker
+-----------------------
+The typing rule for or-patterns in terms of pattern types is
+
+ Γ0, Σ0 ⊢ pat_i : τ ⤳ Γ0,Σi,Ψi
+ --------------------------------------------
+ Γ0, Σ0 ⊢ ( pat_1; ...; pat_n ) : τ ⤳ Γ0,Σ0,∅
+
+(See the proposal for what a pattern type `Γ, Σ ⊢ pat : τ ⤳ Γ,Σ,Ψ` is.)
+The main points
+
+ * None of the patterns may bind any variables, hence the same Γ0 in both input
+ and output.
+ * Any Given constraints bound by the pattern are discarded: the rule discards
+ the Σi returned by each pattern.
+ * Similarly any existentials Ψi bound by the pattern are discarded.
+
+In GHC.Rename.Pat.rnPatAndThen, we reject visible term and type binders (i.e.
+concerning Γ0).
+
+Regarding the Givens Σi and existenials Ψi (i.e. invisible type binders)
+introduced by the pattern alternatives `pat_i`, we discard them in
+GHC.Tc.Gen.Pats.tc_pat in a manner similar to LazyPats;
+see Note [Hopping the LIE in lazy patterns].
+
+Why is it useful to allow Σi and Ψi only to discard them immediately after?
+Consider
+
+ data T a where MkT :: forall a x. Num a => x -> T a
+ foo :: T a -> a
+ foo (MkT{}; MkT{}) = 3
+
+We do want to allow matching on MkT{} in or-patterns, despite them invisibly
+binding an existential type variable `x` and a new Given constraint `Num a`.
+Clearly, `x` must be dead in the RHS of foo, because there is no field binder
+that brings it to life, so no harm done.
+But we must be careful not to solve the `Num a` Wanted constraint in the RHS of
+foo with the Given constraint from the pattern alternatives, hence we are
+Hopping the LIE.
+
+Desugarer
+---------
+The desugaring of or-patterns is complicated by the fact that we have to avoid
+exponential code blowup. Consider
+ f (LT; GT) (EQ; GT) = rhs1
+ f _ _ = rhs2
+The naïve desugaring of or-patterns would explode every or-pattern, thus
+ f LT EQ = rhs1
+ f LT GT = rhs1
+ f GT EQ = rhs1
+ f GT GT = rhs1
+ f _ _ = rhs2
+which leads to an exponential number of copies of `rhs1`.
+Our current strategy, implemented in GHC.HsToCore.Match.tidy1, is to
+desugar to LambdaCase and ViewPatterns,
+ f ((\case LT -> True; GT -> True; _ -> False) -> True)
+ ((\case EQ -> True; GT -> True; _ -> False) -> True)
+ = rhs1
+ f _ _ = rhs2
+The existing code for ViewPatterns makes sure that we do not duplicate `rhs1`
+and the Simplifier will take care to turn this into efficient code.
+
+Pattern-match checker
+---------------------
+The changes to the pattern-match checker are described in detail in Section 4.9
+of the 2024 revision of the "Lower Your Guards" paper.
+What follows is a brief summary of that change.
+
+The pattern-match checker desugars patterns as well, into syntactic variants of
+*guard trees* such as `PmMatch`, describing a single Match `f ps | grhss`.
+It used to be that each such guard trees nicely captured the effects of pattern
+matching `ps` in a conjunctive list of `PmGrd`s, each of which refines
+the set of Nablas that reach the RHS of the clause.
+`PmGrd` is the heart of the Lower Your Guards approach: it is compositional,
+simple, and *non-recursive*, unlike or-patterns!
+Conjunction is implemented with the `...Pmc.Check.leftToRight` combinator.
+But to desugar or-patterns, we need to compose with `Pmc.Check.topToBottom`
+to model first match semantics!
+This was previously impossible in the pattern fragment, and indeed is
+incompatible with the simple "list of `PmGrd`s" desugaring of patterns.
+
+So our solution is to generalise "sequence of `PmGrd`" into a series-parallel
+graph `GrdDag`, a special kind of DAG, where "series" corresponds to
+left-to-right sequence and "parallel" corresponds to top-to-bottom or-pattern
+alternatives. Example
+
+ f (LT; GT) True (EQ; GT) = rhs
+
+desugars to
+
+ /- LT <- x -\ /- EQ <- z -\
+ . . True <- y . .-> rhs
+ \- GT <- x ./ \- GT <- z -/
+
+Branching is GdAlt and models first-match semantics of or-patterns, and
+sequencing is GdSeq.
+
+We must take care of exponential explosion of Covered sets for long matches like
+ g (LT; GT) (LT; GT) ... True = 1
+Fortunately, we can build on our existing throttling mechanism;
+see Note [Countering exponential blowup] in GHC.HsToCore.Pmc.Check.
-}
+
-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
-- parentheses under precedence @p@.
patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
@@ -865,6 +996,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 {}) = p > topPrec
go (SplicePat {}) = False
go (ConPat { pat_args = ds })
= conPatNeedsParens p ds
@@ -947,6 +1079,7 @@ collectEvVarsPat pat =
BangPat _ p -> collectEvVarsLPat p
ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ OrPat _ ps -> unionManyBags $ map collectEvVarsLPat (NE.toList ps)
SumPat _ p _ _ -> collectEvVarsLPat p
ConPat
{ pat_args = args
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 885397f28711..1a042ae3fa14 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 689fefa9a034..cee6d085488b 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1258,6 +1258,10 @@ 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 _ _ -> []
+ -- See Note [Implementation of OrPatterns], Renamer:
+ -- evidence binders in an OrPat currently aren't visible outside their
+ -- binding pattern, so we return [].
SumPat _ pat _ _ -> collect_lpat flag pat bndrs
LitPat _ _ -> bndrs
NPat {} -> bndrs
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index ec4e9f1b9124..5e413a0adbe9 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -463,9 +463,9 @@ dsExpr (HsLet _ binds body) = do
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts
+dsExpr (HsDo res_ty ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty
+dsExpr (HsDo res_ty ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts res_ty
+dsExpr (HsDo res_ty ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty
dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
dsExpr (HsIf _ guard_expr then_expr else_expr)
@@ -743,8 +743,12 @@ handled in GHC.HsToCore.ListComp). Basically does the translation given in the
Haskell 98 report:
-}
-dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
-dsDo ctx stmts
+dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
+-- SG: Surprisingly, this code path seems inactive for regular Do,
+-- which is expanded in GHC.Tc.Gen.Do.
+-- It's all used for ApplicativeDo (even the BindStmt case), which is *very*
+-- annoying because it is a lot of duplicated code that is seldomly tested.
+dsDo ctx stmts res_ty
= goL stmts
where
goL [] = panic "dsDo"
@@ -765,6 +769,9 @@ dsDo ctx stmts
; dsLocalBinds binds rest }
go _ (BindStmt xbs pat rhs) stmts
+ -- SG: As far as I can tell, this code path is only triggered when ApplicativeDo fails, e.g.
+ -- do blah <- action1; action2 (blah * 2)
+ -- It is reached when compiling GHC.Parser.PostProcess.Haddock.addHaddockToModule
= do { var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
; rhs' <- dsLExpr rhs
; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
@@ -772,7 +779,7 @@ dsDo ctx stmts
-- NB: "goL stmts" needs to happen inside matchSinglePatVar, and not
-- before it, so that long-distance information is properly threaded.
-- See Note [Long-distance information in do notation].
- ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
+ ; match_code <- dsHandleMonadicFailure ctx pat res_ty match (xbstc_failOp xbs)
; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids
@@ -824,7 +831,7 @@ dsDo ctx stmts
do_arg (ApplicativeArgOne fail_op pat expr _) =
((pat, fail_op), dsLExpr expr)
do_arg (ApplicativeArgMany _ stmts ret pat _) =
- ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))
+ ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]) res_ty)
; rhss' <- sequence rhss
@@ -835,7 +842,7 @@ dsDo ctx stmts
do { var <- selectSimpleMatchVarL ManyTy pat
; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
body_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
+ ; match_code <- dsHandleMonadicFailure ctx pat body_ty match fail_op
; return (var:vs, match_code)
}
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 27d2027c9bce..90fdc06bf1dc 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -608,7 +608,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
-- NB: dsMcStmts needs to happen inside matchSinglePatVar, and not
-- before it, so that long-distance information is properly threaded.
-- See Note [Long-distance information in do notation] in GHC.HsToCore.Expr.
- ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op
+ ; match_code <- dsHandleMonadicFailure MonadComp pat res1_ty match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 6f98f4033f7e..b2c51bdce361 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -25,11 +25,9 @@ where
import GHC.Prelude
import GHC.Platform
-import Language.Haskell.Syntax.Basic (Boxity(..))
-
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), requiresPMC )
+import GHC.Types.Basic
import GHC.Types.SourceText
( FractionalLit,
@@ -80,7 +78,7 @@ import GHC.Types.Unique.DFM
import Control.Monad ( zipWithM, unless )
import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NEL
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
{-
@@ -198,7 +196,7 @@ match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
match [] ty eqns
= assertPpr (not (null eqns)) (ppr ty) $
- combineEqnRhss (NEL.fromList eqns)
+ combineEqnRhss (NE.fromList eqns)
match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
= assertPpr (all (isInternalName . idName) vars) (ppr vars) $
@@ -240,8 +238,8 @@ match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo {} -> matchCoercion vars ty (dropGroup eqns)
PgView {} -> matchView vars ty (dropGroup eqns)
- where eqns' = NEL.toList eqns
- ne l = case NEL.nonEmpty l of
+ where eqns' = NE.toList eqns
+ ne l = case NE.nonEmpty l of
Just nel -> nel
Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
@@ -270,11 +268,11 @@ matchEmpty var res_ty
matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
-matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
+matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns
matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchBangs (var :| vars) ty eqns
- = do { match_result <- match (var:vars) ty $ NEL.toList $
+ = do { match_result <- match (var:vars) ty $ NE.toList $
decomposeFirstPat getBangPat <$> eqns
; return (mkEvalMatchResult var ty match_result) }
@@ -284,7 +282,7 @@ matchCoercion (var :| vars) ty eqns@(eqn1 :| _)
= do { let XPat (CoPat co pat _) = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
- ; match_result <- match (var':vars) ty $ NEL.toList $
+ ; match_result <- match (var':vars) ty $ NE.toList $
decomposeFirstPat getCoPat <$> eqns
; dsHsWrapper co $ \core_wrap -> do
{ let bind = NonRec var' (core_wrap (Var var))
@@ -300,7 +298,7 @@ matchView (var :| vars) ty eqns@(eqn1 :| _)
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
- ; match_result <- match (var':vars) ty $ NEL.toList $
+ ; match_result <- match (var':vars) ty $ NE.toList $
decomposeFirstPat getViewPat <$> eqns
-- compile the view expressions
; viewExpr' <- dsExpr viewExpr
@@ -507,6 +505,34 @@ tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
warnAboutOverflowedOverLit lit2
; return (idDsWrapper, n) }
+tidy1 _ _ (OrPat ty lpats)
+ -- See Note [Implementation of OrPatterns]. We desugar
+ -- (1; 2; 3)
+ -- to
+ -- ((\case 1 -> True; 2 -> True; 3 -> True; _ -> False) -> True)
+ = return (idDsWrapper, ViewPat ty (noLocA (HsLam [] LamCase mg)) (mkPrefixConPat trueDataCon [] []))
+ where
+ mg :: MatchGroup GhcTc (LHsExpr GhcTc)
+ mg = MG mgtc (noLocA (map match_true (NE.toList lpats) ++ [match_false (noLocA $ WildPat ty)]))
+ mgtc = MatchGroupTc
+ { mg_arg_tys = [tymult ty]
+ , mg_res_ty = boolTy
+ , mg_origin = Generated OtherExpansion SkipPmc
+ -- The or-pattern has already been PM-checked;
+ -- checking the desugaring only leads to confusing warnings
+ }
+ match_true :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
+ match_true lpat = mk_match lpat (hs_var trueDataConId)
+ match_false :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
+ match_false lpat = mk_match lpat (hs_var falseDataConId)
+ mk_match :: LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
+ mk_match lpat body = noLocA $ Match [] CaseAlt [lpat] (single_grhs body)
+
+ hs_var :: Var -> LHsExpr GhcTc
+ hs_var v = (noLocA $ HsVar noExtField (noLocA v))
+ single_grhs :: LHsExpr GhcTc -> GRHSs GhcTc (LHsExpr GhcTc)
+ single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField)
+
-- Everything else goes through unchanged...
tidy1 _ _ non_interesting_pat
= return (idDsWrapper, non_interesting_pat)
@@ -525,6 +551,8 @@ tidy_bang_pat v g l (AsPat x v' p)
= tidy1 v g (AsPat x v' (L l (BangPat noExtField p)))
tidy_bang_pat v g l (XPat (CoPat w p t))
= tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v g l (OrPat x (p:|ps)) -- push bang into first pat alt
+ = tidy1 v g (OrPat x (L l (BangPat noExtField p) :| ps))
-- Discard bang around strict pattern
tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p
@@ -833,7 +861,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs ldi_nablas m
= expectJust "GRHSs non-empty"
- $ NEL.nonEmpty
+ $ NE.nonEmpty
$ replicate (length (grhssGRHSs m)) ldi_nablas
{- Note [Long-distance information in matchWrapper]
@@ -1029,7 +1057,7 @@ groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationI
-- (b) none of the gi are empty
-- The ordering of equations is unchanged
groupEquations platform eqns
- = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
+ = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
-- comprehension on NonEmpty
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
@@ -1048,11 +1076,11 @@ subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
-- Parameterized by map operations to allow different implementations
-- and constraints, eg. types without Ord instance.
subGroup elems empty lookup insert group
- = fmap NEL.reverse $ elems $ foldl' accumulate empty group
+ = fmap NE.reverse $ elems $ foldl' accumulate empty group
where
accumulate pg_map (pg, eqn)
= case lookup pg pg_map of
- Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
+ Just eqns -> insert pg (NE.cons eqn eqns) pg_map
Nothing -> insert pg [eqn] pg_map
-- pg_map :: Map a [EquationInfo]
-- Equations seen so far in reverse order of appearance
diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
index 09108c0a64e2..49bf632dff94 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ b/compiler/GHC/HsToCore/Pmc/Check.hs
@@ -47,22 +47,33 @@ import GHC.Core.Utils
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.
-- If a value matches the resulting action, then it either matches the
-- first action or matches the second action.
-- Basically the semantics of the LYG branching construct.
-topToBottom :: (top -> bot -> ret)
+topToBottom :: ((Nablas -> (Precision, Nablas)) -> top -> bot -> (Precision, ret))
-> CheckAction top
-> CheckAction bot
-> CheckAction ret
topToBottom f (CA top) (CA bot) = CA $ \inc -> do
t <- top inc
b <- bot (cr_uncov t)
- pure CheckResult { cr_ret = f (cr_ret t) (cr_ret b)
+ limit <- maxPmCheckModels <$> getDynFlags
+ -- See Note [Countering exponential blowup]
+ let throttler cov = throttle limit inc cov
+ let (prec', ret) = f throttler (cr_ret t) (cr_ret b)
+ pure CheckResult { cr_ret = ret
, cr_uncov = cr_uncov b
- , cr_approx = cr_approx t Semi.<> cr_approx b }
+ , cr_approx = prec' Semi.<> cr_approx t Semi.<> cr_approx b }
-- | Composes 'CheckAction's left-to-right:
@@ -95,12 +106,14 @@ 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 (no_throttling (NE.<|)) (act t1) (checkAlternatives act (t2:|ts))
+ where
+ no_throttling f _throttler t b = (Precise, f t b)
emptyRedSets :: RedSets
-- Semigroup instance would be misleading!
@@ -152,33 +165,52 @@ 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.
+ -- After the GdAlt, we unite the covered sets. If they become too large, we
+ -- throttle, continuing with the incoming set.
+ merge throttler ri_t ri_b =
+ let (prec, cov) = throttler (rs_cov ri_t Semi.<> rs_cov ri_b) in
+ (prec, RedSets { rs_cov = cov
+ , 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]
@@ -270,8 +302,8 @@ will be checked against the initial Nabla, {}. Doing so will produce an
Uncovered set of size 2, containing the models {xâ‰True} and {x~True,yâ‰True}.
Also we find the first clause to cover the model {x~True,y~True}.
-But the Uncovered set we get out of the match is too huge! We somehow have to
-ensure not to make things worse as they are already, so we continue checking
+But the Uncovered set we get out of the match is too large! We somehow have to
+ensure not to make things worse than they are already, so we continue checking
with a singleton Uncovered set of the initial Nabla {}. Why is this
sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts
to forgetting that we matched against the first clause. The values represented
@@ -293,6 +325,15 @@ Guards are an extreme example in this regard, with #11195 being a particularly
dreadful example: Since their RHS are often pretty much unique, we split on a
variable (the one representing the RHS) that doesn't occur anywhere else in the
program, so we don't actually get useful information out of that split!
+We counter this by throttling *Uncovered* sets in `leftToRight`.
+
+Another challenge is posed by or-patterns (see also Note [Implementation of OrPatterns]):
+Large matches such as `f (LT; GT) (LT; GT) .... True = 1` will desugar into
+a long sequence of `GdAlt LT GT`. The careless desugaring of `GdAlt` via
+`topToBottom` would cause ever enlarging *Covered* sets.
+So we throttle when merging Covered sets from LT and GT, by using the original
+incoming covered set. The effect is very like replacing (LT; GT) with a wildcard
+pattern _.
Note [considerAccessible]
~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index fb0e315e9741..53374db5561f 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,29 +100,28 @@ 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
- EmbTyPat _ _ -> pure []
- InvisPat _ _ -> pure []
+ EmbTyPat _ _ -> pure GdEnd
+ InvisPat _ _ -> pure GdEnd
XPat ext -> case ext of
@@ -157,24 +154,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
@@ -238,41 +231,44 @@ 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])
@@ -314,15 +310,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 }
@@ -339,10 +335,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
@@ -351,7 +347,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)
@@ -364,11 +360,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
@@ -379,22 +375,25 @@ desugarGuard guard = case guard of
RecStmt {} -> panic "desugarGuard RecStmt"
XStmtLR 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
@@ -410,14 +409,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
@@ -425,24 +424,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 46c159c9518e..20e5c2e9baf6 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(..),
@@ -103,8 +105,51 @@ 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 @(LT; EQ)@, succeeding if the
+-- match variable matches /either/ 'LT' or 'EQ'.
+-- See Note [Implementation of OrPatterns] for a larger example.
+--
+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))
@@ -139,9 +184,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 $ 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> }@
@@ -236,7 +287,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/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index ae09974f2c7f..1a9ac90224c9 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -2096,6 +2096,9 @@ repLambda (L _ m) = notHandled (ThGuardedLambdas m)
repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])
repLPs ps = repListM patTyConName repLP ps
+repLPs1 :: NonEmpty (LPat GhcRn) -> MetaM (Core (NonEmpty (M TH.Pat)))
+repLPs1 ps = repNonEmptyM patTyConName repLP ps
+
repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
repLP p = repP (unLoc p)
@@ -2150,6 +2153,7 @@ repP (EmbTyPat _ t) = do { t' <- repLTy (hstp_body t)
; repPtype t' }
repP (InvisPat _ t) = do { t' <- repLTy (hstp_body t)
; repPinvis t' }
+repP (OrPat _ ps) = do { ps' <- repLPs1 ps; repPor ps' }
repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n
repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p)
repP other = notHandled (ThExoticPattern other)
@@ -2403,6 +2407,9 @@ repPlist (MkC ps) = rep2 listPName [ps]
repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+repPor :: Core (NonEmpty (M TH.Pat)) -> MetaM (Core (M TH.Pat))
+repPor (MkC ps) = rep2 orPName [ps]
+
repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
@@ -3082,6 +3089,16 @@ repListM tc_name f args
; args1 <- mapM f args
; return $ coreList' ty args1 }
+repNonEmptyM
+ :: Name
+ -> (a -> MetaM (Core b))
+ -> NonEmpty a -> MetaM (Core (NonEmpty b))
+repNonEmptyM tc_name f args
+ = do { ty <- wrapName tc_name
+ ; args' <- traverse f args
+ ; ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName -- the DataCon is not known-key
+ ; return $ coreListNonEmpty ne_tycon ty args' }
+
coreListM :: Name -> [Core a] -> MetaM (Core [a])
coreListM tc as = repListM tc return as
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 1ba337a16767..962f51baf5fe 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -80,6 +80,7 @@ import GHC.Types.Tickish
import GHC.Utils.Misc
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
+import GHC.Rename.Utils
import qualified GHC.LanguageExtensions as LangExt
import GHC.Tc.Types.Evidence
@@ -969,25 +970,34 @@ CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see #3403.
-}
-dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
- -- In a do expression, pattern-match failure just calls
- -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure ctx pat match m_fail_op =
+dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> Type -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+ -- In an ApplicativeDo expression, pattern-match failure just calls the
+ -- monadic 'fail' rather than throwing an exception.
+dsHandleMonadicFailure ctx pat res_ty match m_fail_op =
case shareFailureHandler match of
MR_Infallible body -> body
MR_Fallible body -> do
- fail_op <- case m_fail_op of
+ dflags <- getDynFlags
+ fail_expr <- case m_fail_op of
-- Note that (non-monadic) list comprehension, pattern guards, etc could
-- have fallible bindings without an explicit failure op, but this is
-- handled elsewhere. See Note [Failing pattern matches in Stmts] the
-- breakdown of regular and special binds.
- Nothing -> pprPanic "missing fail op" $
- text "Pattern match:" <+> ppr pat <+>
- text "is failable, and fail_expr was left unset"
- Just fail_op -> pure fail_op
- dflags <- getDynFlags
- fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)
- fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+ -- It *is* possible to land here for infallible Or patterns in
+ -- ApplicativeDo, because their desugaring to ViewPatterns leads
+ -- to a MR_Fallible match. But irrefutability is easily asserted:
+ Nothing -> do
+ massertPpr (isIrrefutableHsPat dflags pat) $
+ text "Pattern match:" <+> ppr pat <+>
+ text "is failable, and fail_expr was left unset"
+ -- In this case we likely desugar the pattern-match in something like
+ -- do (~True; False) <- m; stmts
+ -- just presume a fail_expr like in the desugaring of lambdas;
+ -- that's the non-ApplicativeDo code path
+ mkErrorAppDs pAT_ERROR_ID res_ty (matchDoContextErrString ctx)
+ Just fail_op -> do
+ fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)
+ dsSyntaxExpr fail_op [fail_msg]
body fail_expr
mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 1ed1cec133a0..a02a69505587 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -964,6 +964,8 @@ toHieHsStmtContext ctxt
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 e5879c1902e7..8acc77843496 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -476,7 +476,7 @@ Ambiguity:
-}
{- Note [%shift: activation -> {- empty -}]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Context:
sigdecl -> '{-# INLINE' . activation qvarcon '#-}'
activation -> {- empty -}
@@ -493,6 +493,37 @@ Ambiguity:
empty activation and inlining '[0] Something'.
-}
+{- Note [%shift: orpats -> exp]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Context:
+
+ texp -> exp .
+ orpats -> exp .
+ texp -> exp . '->' texp
+ orpats -> exp . ';' orpats
+
+ in Lookahead ')': reduce/reduce conflict between the two first productions
+
+Example:
+
+ f (True) = 3
+ ----^
+
+Ambiguity:
+ We don't know whether the ')' encloses a parenthesized pat (reduce with
+ first production) or a unary Or pattern (reduce with second production).
+ We want to parse it as a parenthesized pat, because
+ * That is the status quo
+ * Parsing it as a unary Or patterns prompts the user to activate -XOrPatterns.
+ Thus, we add a %shift pragma to `orpats -> exp` to lower its precedence,
+ which has the effect of letting `texp -> exp` win (!).
+
+An alternative to resolve this ambiguity would be to accept only OrPatterns
+with at least two patterns in `orpats`, just as in `tup_exprs`.
+But the present code seems simpler, because it just needs one non-terminal,
+at the expense of using a small pragma.
+-}
+
{- Note [Parser API Annotations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A lot of the productions are now cluttered with calls to
@@ -1642,18 +1673,18 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 }
-- Glasgow extension: pattern synonyms
pattern_synonym_decl :: { LHsDecl GhcPs }
- : 'pattern' pattern_synonym_lhs '=' pat
+ : 'pattern' pattern_synonym_lhs '=' pat_syn_pat
{% let (name, args, as ) = $2 in
amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4
ImplicitBidirectional
(as ++ [mj AnnPattern $1, mj AnnEqual $3])) }
- | 'pattern' pattern_synonym_lhs '<-' pat
+ | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat
{% let (name, args, as) = $2 in
amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional
(as ++ [mj AnnPattern $1,mu AnnLarrow $3])) }
- | 'pattern' pattern_synonym_lhs '<-' pat where_decls
+ | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat where_decls
{% do { let (name, args, as) = $2
; mg <- mkPatSynMatchGroup name $5
; amsA' (sLL $1 $> . ValD noExtField $
@@ -2997,6 +3028,11 @@ aexp2 :: { ECP }
mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2
[mop $1,mcp $3]}
+ | '(' orpats ')' {% do
+ { pat <- hintOrPats (sL1a $2 (OrPat NoExtField (unLoc $2)))
+ ; fmap ecpFromPat
+ (amsA' (sLL $1 $> (ParPat (epTok $1, epTok $>) pat))) }}
+
-- This case is only possible when 'OverloadedRecordDotBit' is enabled.
| '(' projection ')' { ECP $
amsA' (sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (AnnProjection (glAA $1) (glAA $3)) )
@@ -3094,7 +3130,7 @@ cvtopdecls0 :: { [LHsDecl GhcPs] }
-- things that can appear unparenthesized as long as they're
-- inside parens or delimited by commas
texp :: { ECP }
- : exp { $1 }
+ : exp { $1 }
-- Note [Parsing sections]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -3125,6 +3161,16 @@ texp :: { ECP }
unECP $3 >>= \ $3 ->
mkHsViewPatPV (comb2 $1 $>) $1 $3 [mu AnnRarrow $2] }
+orpats :: { Located (NonEmpty (LPat GhcPs)) }
+ -- See Note [%shift: orpats -> exp]
+ : exp %shift {% do
+ { pat <- (checkPattern <=< runPV) (unECP $1)
+ ; return (sL1 pat (NE.singleton pat)) }}
+ | exp ';' orpats {% do
+ { pat <- (checkPattern <=< runPV) (unECP $1)
+ ; pat <- addTrailingSemiA pat (getLoc $2)
+ ; return (sLL pat $> (pat NE.<| unLoc $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]
@@ -3382,8 +3428,15 @@ gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }
-- e.g. "!x" or "!(x,y)" or "C a b" etc
-- Bangs inside are parsed as infix operator applications, so that
-- we parse them right when bang-patterns are off
+
+pat_syn_pat :: { LPat GhcPs }
+pat_syn_pat : exp {% (checkPattern <=< runPV) (unECP $1) }
+
pat :: { LPat GhcPs }
-pat : exp {% (checkPattern <=< runPV) (unECP $1) }
+pat : orpats {% case unLoc $1 of
+ pat :| [] -> return pat
+ pats -> hintOrPats (sL1a $1 (OrPat NoExtField pats)) }
+
-- '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
@@ -4259,6 +4312,13 @@ looksLikeMult ty1 l_op ty2
= True
| otherwise = False
+-- Hint about or-patterns
+hintOrPats :: MonadP m => LPat GhcPs -> m (LPat GhcPs)
+hintOrPats pat = do
+ orPatsEnabled <- getBit OrPatternsBit
+ unless orPatsEnabled $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) $ PsErrIllegalOrPat pat
+ return pat
+
-- 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 1d7f6e827717..c1ef02a2198b 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -349,6 +349,11 @@ instance Diagnostic PsMessage where
sep [ text "View pattern in expression context:"
, nest 4 (ppr a <+> text "->" <+> ppr b)
]
+ PsErrOrPatInExpr p
+ -> mkSimpleDecorated $
+ sep [ text "Or pattern in expression context:"
+ , nest 4 (ppr p)
+ ]
PsErrCaseCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a
PsErrLambdaCmdInFunAppCmd lam_variant a
@@ -532,6 +537,9 @@ instance Diagnostic PsMessage where
, text "Use" <+> quotes (text "Sum<n># a b c ...") <+> text "to refer to the type constructor."
]
+ PsErrIllegalOrPat pat
+ -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)]
+
diagnosticReason = \case
PsUnknownMessage m -> diagnosticReason m
PsHeaderMessage m -> psHeaderMessageReason m
@@ -609,6 +617,7 @@ instance Diagnostic PsMessage where
PsErrArrowCmdInPat{} -> ErrorWithoutFlag
PsErrArrowCmdInExpr{} -> ErrorWithoutFlag
PsErrViewPatInExpr{} -> ErrorWithoutFlag
+ PsErrOrPatInExpr{} -> ErrorWithoutFlag
PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag
@@ -647,6 +656,7 @@ instance Diagnostic PsMessage where
PsErrMultipleConForNewtype {} -> ErrorWithoutFlag
PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag
PsErrInvalidPun {} -> ErrorWithoutFlag
+ PsErrIllegalOrPat{} -> ErrorWithoutFlag
diagnosticHints = \case
PsUnknownMessage m -> diagnosticHints m
@@ -743,6 +753,7 @@ instance Diagnostic PsMessage where
PsErrArrowCmdInPat{} -> noHints
PsErrArrowCmdInExpr{} -> noHints
PsErrViewPatInExpr{} -> noHints
+ PsErrOrPatInExpr{} -> noHints
PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs
@@ -813,6 +824,7 @@ instance Diagnostic PsMessage where
PsErrMultipleConForNewtype {} -> noHints
PsErrUnicodeCharLooksLike{} -> noHints
PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns]
+ PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns]
diagnosticCode = constructorCode
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 3b12a18f93af..feaf4a82b6a6 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -270,6 +270,9 @@ data PsMessage
-- | View-pattern in expression
| PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)
+ -- | Or-pattern in expression
+ | PsErrOrPatInExpr !(LPat GhcPs)
+
-- | Type-application without space before '@'
| PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)
@@ -461,6 +464,9 @@ data PsMessage
| PsErrInvalidPun !PsErrPunDetails
+ -- | Or pattern used without -XOrPatterns
+ | PsErrIllegalOrPat (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 3f2c5dd1def0..039248014a63 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -3060,6 +3060,7 @@ data ExtBits
| NoLexicalNegationBit -- See Note [Why not LexicalNegationBit]
| OverloadedRecordDotBit
| OverloadedRecordUpdateBit
+ | OrPatternsBit
| ExtendedLiteralsBit
| ListTuplePunsBit
@@ -3141,6 +3142,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
.|. ExtendedLiteralsBit `xoptBit` LangExt.ExtendedLiterals
.|. ListTuplePunsBit `xoptBit` LangExt.ListTuplePuns
optBits =
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 6b77345edc10..b84f7b50b43a 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -104,6 +104,7 @@ module GHC.Parser.PostProcess (
DisambECP(..),
ecpFromExp,
ecpFromCmd,
+ ecpFromPat,
PatBuilder,
hsHoleExpr,
@@ -1224,6 +1225,8 @@ checkLPat (L l@(EpAnn anc an _) p) = do
checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
+-- SG: I think this function checks what Haskell2010 calls the `pat` and `lpat`
+-- productions
checkPat loc cs (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?
@@ -1547,6 +1550,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))
@@ -1587,6 +1593,8 @@ 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)
+ -- | Return a pattern without ambiguity, or fail in a non-pattern context.
+ ecpFromPat' :: LPat GhcPs -> PV (LocatedA b)
mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
-- | Disambiguate "let ... in ..."
@@ -1735,6 +1743,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 p) = cmdFail (locA l) (ppr p)
mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
PsErrOverloadedRecordDotInvalid
mkHsLamPV l lam_variant (L lm m) anns = do
@@ -1822,6 +1831,9 @@ instance DisambECP (HsExpr GhcPs) where
addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c
return (L l (hsHoleExpr noAnn))
ecpFromExp' = return
+ ecpFromPat' p@(L l _) = do
+ addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrOrPatInExpr p
+ return (L l (hsHoleExpr noAnn))
mkHsProjUpdatePV l fields arg isPun anns = do
!cs <- getCommentsFor l
return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns
@@ -1916,6 +1928,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' (L l p) = return $ L l (PatBuilderPat p)
mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
type InfixOp (PatBuilder GhcPs) = RdrName
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index ff0c3b251dab..4b3220c42640 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -572,6 +572,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 ce05bde46823..a43f731ae9a8 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -2148,7 +2148,7 @@ stmtTreeToStmts
-- change the @return@ to @pure@.
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))
tail _tail_fvs
- | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing
+ | definitelyLazyPattern pat, (False,tail') <- needJoin monad_names tail Nothing
-- See Note [ApplicativeDo and strict patterns]
= mkApplicativeStmt ctxt [ApplicativeArgOne
{ xarg_app_arg_one = xbsrn_failOp xbs
@@ -2271,15 +2271,15 @@ segments stmts = merge $ reverse $ map reverse $ walk (reverse stmts)
(_, fvs') = stmtRefs stmt fvs
chunter _ [] = ([], [])
- chunter vars ((stmt,fvs) : rest)
- | not (isEmptyNameSet vars)
- || isStrictPatternBind stmt
+ chunter vars orig@((stmt,fvs) : rest)
+ | isEmptyNameSet vars, definitelyLazyPatternBind stmt
+ = ([], orig)
+ | otherwise
-- See Note [ApplicativeDo and strict patterns]
= ((stmt,fvs) : chunk, rest')
where (chunk,rest') = chunter vars' rest
(pvars, evars) = stmtRefs stmt fvs
vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
- chunter _ rest = ([], rest)
stmtRefs stmt fvs
| isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
@@ -2287,9 +2287,9 @@ segments stmts = merge $ reverse $ map reverse $ walk (reverse stmts)
where fvs' = fvs `intersectNameSet` allvars
pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt))
- isStrictPatternBind :: ExprLStmt GhcRn -> Bool
- isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
- isStrictPatternBind _ = False
+ definitelyLazyPatternBind :: ExprLStmt GhcRn -> Bool
+ definitelyLazyPatternBind (L _ (BindStmt _ pat _)) = definitelyLazyPattern pat
+ definitelyLazyPatternBind _ = True
{-
Note [ApplicativeDo and strict patterns]
@@ -2309,45 +2309,67 @@ allowed this to be transformed into
then it could be lazier than the standard desugaring using >>=. See #13875
for more examples.
-Thus, whenever we have a strict pattern match, we treat it as a
+Thus, whenever we have a potentially strict pattern match, we treat it as a
dependency between that statement and the following one. The
dependency prevents those two statements from being performed "in
parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
can do with the rest of the statements in the same "do" expression.
+
+The necessary "definitely lazy" test is similar, but distinct to irrefutability.
+See Note [definitelyLazyPattern vs. isIrrefutableHsPat].
+
+Note [definitelyLazyPattern vs. isIrrefutableHsPat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lazy patterns are irrefutable, but not all irrefutable patterns are lazy.
+Examples:
+ * (x,y) is an irrefutable pattern, but not lazy.
+ * x is both irrefutable and lazy.
+ * The or pattern (~True; False) is both irrefutable and lazy,
+ because the first pattern alt accepts without forcing the scrutinee.
+ * The or pattern (False; ~True) is irrefutable, but not lazy,
+ because the first pattern alt forces the scrutinee and may fail,
+ but the second alt is irrefutable and hence the whole pattern is.
-}
-isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
-isStrictPattern (L loc pat) =
+definitelyLazyPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
+-- See Note [definitelyLazyPattern vs. isIrrefutableHsPat]
+-- A conservative analysis that says False if in doubt, hence "definitely".
+-- E.g., the ViewPat (const 5 -> 13) is really lazy, but below we say False.
+definitelyLazyPattern (L loc pat) =
case pat of
- WildPat{} -> False
- VarPat{} -> False
- LazyPat{} -> False
- AsPat _ _ p -> isStrictPattern p
- ParPat _ p -> isStrictPattern p
- ViewPat _ _ p -> isStrictPattern p
- SigPat _ p _ -> isStrictPattern p
- BangPat{} -> True
- ListPat{} -> True
- TuplePat{} -> True
- SumPat{} -> True
- ConPat{} -> True
- LitPat{} -> True
- NPat{} -> True
- NPlusKPat{} -> True
- SplicePat{} -> True
+ WildPat{} -> True
+ VarPat{} -> True
+ LazyPat{} -> True
+ AsPat _ _ p -> definitelyLazyPattern p
+ ParPat _ p -> definitelyLazyPattern p
+ ViewPat _ _f p -> definitelyLazyPattern p --- || definitelyLazyFun _f
+ -- NB: We keep it simple and assume `definitelyLazyFun _ = False`
+ SigPat _ p _ -> definitelyLazyPattern p
+ OrPat _ p -> definitelyLazyPattern (NE.head p)
+ -- NB: foo (~True; False) = () is lazy!
+ -- See Note [definitelyLazyPattern vs. isIrrefutableHsPat]
+ BangPat{} -> False
+ ListPat{} -> False
+ TuplePat{} -> False
+ SumPat{} -> False
+ ConPat{} -> False -- Some PatSyns are lazy; False is conservative
+ LitPat{} -> False
+ NPat{} -> False -- Some NPats are lazy; False is conservative
+ NPlusKPat{} -> False
+ SplicePat{} -> False
-- The behavior of this case is unimportant, as GHC will throw an error shortly
-- after reaching this case for other reasons (see TcRnIllegalTypePattern).
- EmbTyPat{} -> False
- InvisPat{} -> False
+ EmbTyPat{} -> True
+ InvisPat{} -> True
XPat ext -> case ghcPass @p of
GhcRn
| HsPatExpanded _ p <- ext
- -> isStrictPattern (L loc p)
+ -> definitelyLazyPattern (L loc p)
GhcTc -> case ext of
- ExpansionPat _ p -> isStrictPattern (L loc p)
- CoPat {} -> panic "isStrictPattern: CoPat"
+ ExpansionPat _ p -> definitelyLazyPattern (L loc p)
+ CoPat {} -> panic "definitelyLazyPattern: CoPat"
{-
Note [ApplicativeDo and refutable patterns]
@@ -2402,7 +2424,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- then we have actually done some splitting. Otherwise it will go into
-- an infinite loop (#14163).
go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)
- | disjointNameSet bndrs fvs && not (isStrictPattern pat)
+ | disjointNameSet bndrs fvs, definitelyLazyPattern pat
= go lets ((L loc (BindStmt xbs pat body), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 1ab350fffc65..501a1ee870ea 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -514,10 +514,12 @@ rnLArgPatAndThen mk = wrapSrcSpanCps rnArgPatAndThen where
-- ----------- Entry point 3: rnLPatAndThen -------------------
-- General version: parameterized by how you make new names
-rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
-rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
+rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
+rnLPatsAndThen mk = traverse (rnLPatAndThen mk)
-- Despite the map, the monad ensures that each pattern binds
-- variables that may be mentioned in subsequent patterns in the list
+{-# SPECIALISE rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] #-}
+{-# SPECIALISE rnLPatsAndThen :: NameMaker -> NE.NonEmpty (LPat GhcPs) -> CpsRn (NE.NonEmpty (LPat GhcRn)) #-}
--------------------
-- The workhorse
@@ -648,6 +650,14 @@ rnPatAndThen mk (TuplePat _ pats boxed)
= do { pats' <- rnLPatsAndThen mk pats
; return (TuplePat noExtField pats' boxed) }
+rnPatAndThen mk (OrPat _ pats)
+ = do { loc <- liftCps getSrcSpanM
+ ; pats' <- rnLPatsAndThen mk pats
+ ; let bndrs = collectPatsBinders CollVarTyVarBinders (NE.toList pats')
+ ; liftCps $ setSrcSpan loc $ checkErr (null bndrs) $
+ TcRnOrPatBindsVariables (NE.fromList (ordNubOn getOccName bndrs))
+ ; return (OrPat noExtField pats') }
+
rnPatAndThen mk (SumPat _ pat alt arity)
= do { pat <- rnLPatAndThen mk pat
; return (SumPat noExtField pat alt arity)
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index cba874bb5a88..04889871e254 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1202,6 +1202,9 @@ instance Diagnostic TcRnMessage where
-- Is the data con a "covert" GADT? See Note [isCovertGadtDataCon]
-- in GHC.Core.DataCon
sneaky_eq_spec = isCovertGadtDataCon con
+ TcRnOrPatBindsVariables bndrs -> mkSimpleDecorated $
+ text "An or-pattern may not bind term or type variables such as"
+ <+> quotedListWithOr (map ppr (NE.toList bndrs))
TcRnUnsatisfiedMinimalDef mindef
-> mkSimpleDecorated $
vcat [text "No explicit implementation for"
@@ -2298,6 +2301,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnIllegalNewtype{}
-> ErrorWithoutFlag
+ TcRnOrPatBindsVariables{}
+ -> ErrorWithoutFlag
TcRnUnsatisfiedMinimalDef{}
-> WarningWithFlag (Opt_WarnMissingMethods)
TcRnMisplacedInstSig{}
@@ -2956,6 +2961,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnIllegalNewtype{}
-> noHints
+ TcRnOrPatBindsVariables{}
+ -> noHints
TcRnUnsatisfiedMinimalDef{}
-> noHints
TcRnMisplacedInstSig{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 7df78d9d8272..de1c809213bb 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2765,7 +2765,17 @@ data TcRnMessage where
-}
TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage
- {-| TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
+ {-| TcRnOrPatBindsVariables is an error that happens when an
+ or-pattern binds term or type variables, e.g. (A @x; B y).
+
+ Test case:
+ testsuite/tests/typecheck/should_fail/Or3
+ -}
+ TcRnOrPatBindsVariables
+ :: NE.NonEmpty (IdP GhcRn) -- ^ List of binders
+ -> TcRnMessage
+
+ {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
is missing methods that are required by the minimal definition.
Example:
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index f7a7771f50a5..f987574b31f1 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -641,6 +641,16 @@ 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 -- See Note [Implementation of OrPatterns], Typechecker (1)
+ { let pats_list = NE.toList pats
+ ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
+ ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- like in Note [Hopping the LIE in lazy patterns]
+ ; pat_ty <- expTypeToType (scaledThing pat_ty)
+ ; return (OrPat pat_ty pats', res) }
+
LazyPat x pat -> do
{ mult_wrap <- checkManyPattern LazyPatternReason (noLocA ps_pat) 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 8a9ea41b0c90..795a6471d01b 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -1072,6 +1072,7 @@ tcPatToExpr 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 (PatSynNotInvertible p)
diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs
index 88d6386ebe8b..0d5beff4ee78 100644
--- a/compiler/GHC/Tc/Zonk/Type.hs
+++ b/compiler/GHC/Tc/Zonk/Type.hs
@@ -100,6 +100,7 @@ import GHC.Data.Bag
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Data.Semigroup
+import Data.List.NonEmpty ( NonEmpty )
{- Note [What is zonking?]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1525,6 +1526,11 @@ zonk_pat (TuplePat tys pats boxed)
; pats' <- zonkPats pats
; return (TuplePat tys' pats' boxed) }
+zonk_pat (OrPat ty pats)
+ = do { ty' <- noBinders $ zonkTcTypeToTypeX ty
+ ; pats' <- zonkPats pats
+ ; return (OrPat ty' pats') }
+
zonk_pat (SumPat tys pat alt arity )
= do { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys
; pat' <- zonkPat pat
@@ -1629,8 +1635,10 @@ zonkConStuff (RecCon (HsRecFields rpats dd))
-- Field selectors have declared types; hence no zonking
---------------------------
-zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc]
+zonkPats :: Traversable f => f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc))
zonkPats = traverse zonkPat
+{-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-}
+{-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-}
{-
************************************************************************
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 99329e8eb16d..666a76092aa4 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1417,8 +1417,10 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
quotedSourceText :: String -> SourceText
quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\""
-cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
+cvtPats :: Traversable f => f (TH.Pat) -> CvtM (f (Hs.LPat GhcPs))
cvtPats pats = mapM cvtPat pats
+{-# SPECIALISE cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] #-}
+{-# SPECIALISE cvtPats :: NonEmpty (TH.Pat) -> CvtM (NonEmpty (Hs.LPat GhcPs)) #-}
cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
cvtPat pat = wrapLA (cvtp pat)
@@ -1492,6 +1494,8 @@ cvtp (TypeP t) = do { t' <- cvtType t
; return $ EmbTyPat noAnn (mkHsTyPat t') }
cvtp (InvisP t) = do { t' <- cvtType t
; pure (InvisPat noAnn (mkHsTyPat t'))}
+cvtp (OrP ps) = do { ps' <- cvtPats ps
+ ; pure (OrPat noExtField ps')}
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index c6b3a2a9f386..a204205adbc9 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -247,6 +247,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrArrowCmdInPat" = 98980
GhcDiagnosticCode "PsErrArrowCmdInExpr" = 66043
GhcDiagnosticCode "PsErrViewPatInExpr" = 66228
+ GhcDiagnosticCode "PsErrOrPatInExpr" = 66718
GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd" = 12178
GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd" = 92971
GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = Outdated 47171
@@ -287,6 +288,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380
GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623
GhcDiagnosticCode "PsErrInvalidPun" = 52943
+ GhcDiagnosticCode "PsErrIllegalOrPat" = 29847
-- Driver diagnostic codes
GhcDiagnosticCode "DriverMissingHomeModules" = 32850
@@ -491,6 +493,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnDifferentExportWarnings" = 92878
GhcDiagnosticCode "TcRnIncompleteExportWarnings" = 94721
GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649
+ GhcDiagnosticCode "TcRnOrPatBindsVariables" = 81303
GhcDiagnosticCode "TcRnIllegalKind" = 64861
GhcDiagnosticCode "TcRnUnexpectedPatSigType" = 74097
GhcDiagnosticCode "TcRnIllegalKindSignature" = 91382
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index e18ea1002df7..f5439ac0dd7d 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -32,7 +32,7 @@ module GHC.Utils.Outputable (
SDoc, runSDoc, PDoc(..),
docToSDoc,
interppSP, interpp'SP, interpp'SP',
- pprQuotedList, pprWithCommas,
+ pprQuotedList, pprWithCommas, pprWithSemis,
unquotedListWith,
quotedListWithOr, quotedListWithNor, quotedListWithAnd,
pprWithBars,
@@ -1390,6 +1390,12 @@ pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
-- comma-separated and finally packed into a paragraph.
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
+pprWithSemis :: (a -> SDoc) -- ^ The pretty printing function to use
+ -> [a] -- ^ The things to be pretty printed
+ -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
+ -- semicolon-separated and finally packed into a paragraph.
+pprWithSemis pp xs = fsep (punctuate semi (map pp xs))
+
pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use
-> [a] -- ^ The things to be pretty printed
-> SDoc -- ^ 'SDoc' where the things have been pretty printed,
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index df7469db49e0..f2f1618a656e 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
@@ -588,6 +588,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 30a8e1ef940f..e63ea9170576 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 Data.List.NonEmpty (NonEmpty)
type LPat p = XRec p (Pat p)
@@ -134,6 +135,10 @@ data Pat p
-- 'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@,
-- 'GHC.Parser.Annotation.AnnClose' @')'@ or @'#)'@
+ | OrPat (XOrPat p)
+ (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 000000000000..3eb7db8b4e6d
--- /dev/null
+++ b/docs/users_guide/exts/or_patterns.rst
@@ -0,0 +1,122 @@
+.. _or-patterns:
+
+Or-Patterns
+-------------
+
+.. extension:: OrPatterns
+ :shortdesc: Enable or-patterns.
+
+ :since: 9.12.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 we have some sum type and code matching on it: ::
+
+ data Sweet = Cupcake | Liquorice | Cookie | Raisins
+
+ tasty Cupcake = True
+ tasty Cookie = True
+ tasty _ = False
+
+Let us say we need to 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 might need adjustment, resulting in
+cheesecake incorrectly being characterised as untasty.
+
+If we want the compiler to aid us in Haskell2010, we must write out all cases
+explicitly, vertically bloating the code.
+This is where Or-patterns help. With :extension:`OrPatterns` we can write: ::
+
+ tasty (Cupcake; Cookie) = True
+ tasty (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
+:ghc-flag:`-Wincomplete-patterns`.
+
+Or-patterns are particularly useful in pattern matches that need to handle a
+high number of constructors. It is not uncommon to see pattern matches that deal
+with dozens of constructors, e.g. in GHC's own source code
+(`Pat.hs <https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Hs/Pat.hs>`_).
+In such cases, the only options are:
+
+- to use a wildcard and at the expense of clarity, and risking bugs when adding new constructors
+
+- to enumerate each constructor, at the expense of duplicating the code of the RHS
+
+- to use an Or-pattern
+
+Specification
+~~~~~~~~~~~~~
+
+An or-pattern looks like this: ::
+
+ (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 ``(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 (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 (G1; G2) = 3 -- cannot solve constraint `Num a`
+
+ data GADT a where
+ IsInt1 :: GADT Int
+ IsInt2 :: GADT Int
+
+ foo :: a -> GADT a -> a
+ foo x (IsInt1; IsInt2) = x + 1 -- cannot solve constraint `Num a`
+
+This is so simply because we have not proposed yet a more general static
+semantics for such or-patterns.
+
+So what *can* or-patterns do?
+
+Apart from reducing code size and duplication, they compose with all forms of
+existing patterns, like view patterns and pattern synonyms: ::
+
+ f :: (Eq a, Show a) => a -> a -> Bool
+ f a ((== a) -> True; show -> "yes") = True
+ f _ _ = False
+
+ small (abs -> (0; 1; 2); 3) = True -- -3 is not small
+ small _ = False
+
+ type Coll a = Either [a] (Set a)
+ pattern None <- (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
+ ((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>`_.)
diff --git a/docs/users_guide/exts/patterns.rst b/docs/users_guide/exts/patterns.rst
index f55583fb0b0a..dce0f9511fbf 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/Internal/TH/Ppr.hs b/libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
index fb35c98b4484..dc88198dbec2 100644
--- a/libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
+++ b/libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
@@ -17,6 +17,7 @@ import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
import Data.Foldable ( toList )
+import qualified Data.List.NonEmpty as NE
import Prelude hiding ((<>))
nestDepth :: Int
@@ -394,6 +395,7 @@ pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
pprPat _ (TypeP t) = parens $ text "type" <+> ppr t
pprPat _ (InvisP t) = parens $ text "@" <+> ppr t
+pprPat _ (OrP t) = parens $ semiSep (NE.toList t)
------------------------------
instance Ppr Dec where
diff --git a/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs b/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
index d2fc5d903697..9c0359d76513 100644
--- a/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
@@ -71,6 +71,7 @@ data Extension
| RecordWildCards
| NamedFieldPuns
| ViewPatterns
+ | OrPatterns
| GADTs
| GADTSyntax
| NPlusKPatterns
diff --git a/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs b/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
index 28e6c8040b0d..2e9b4ec41860 100644
--- a/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
@@ -187,6 +187,9 @@ viewP e p = do e' <- e
p' <- p
pure (ViewP e' p')
+orP :: Quote m => (NonEmpty (m Pat)) -> m Pat
+orP ps = do ps' <- sequenceA ps
+ pure (OrP ps')
fieldPat :: Quote m => Name -> m Pat -> m FieldPat
fieldPat n p = do p' <- p
diff --git a/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs b/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
index f58432d97c7b..51991d755981 100644
--- a/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
@@ -1789,6 +1789,7 @@ data Pat
| ViewP Exp Pat -- ^ @{ e -> p }@
| TypeP Type -- ^ @{ type p }@
| InvisP Type -- ^ @{ @p }@
+ | OrP (NonEmpty Pat) -- ^ @{ p1; p2 }@
deriving( Show, Eq, Ord, Data, Generic )
-- | A (field name, pattern) pair. See 'RecP'.
diff --git a/testsuite/tests/ado/OrPatStrictness.hs b/testsuite/tests/ado/OrPatStrictness.hs
new file mode 100644
index 000000000000..af8569a3712c
--- /dev/null
+++ b/testsuite/tests/ado/OrPatStrictness.hs
@@ -0,0 +1,22 @@
+-- {-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+-- {-# OPTIONS_GHC -O2 -fforce-recomp #-}
+{-# LANGUAGE OrPatterns, ApplicativeDo #-}
+
+import Data.Functor.Identity
+import Debug.Trace
+
+data T = M1 | M2 | M3 deriving Show
+
+instance MonadFail Identity where fail = error "never happens"
+
+blah :: Identity T -> Identity T -> Identity T -> Identity T
+blah m1 m2 m3 = do
+ (~M1; M2) <- m1 -- a lazy pattern
+ (M1; M2; M3) <- m2 -- a strict pattern
+ z <- m3
+ return z
+{-# NOINLINE blah #-}
+
+main = print (blah (trace "m1" (Identity M1))
+ (trace "m2" (Identity M2))
+ (trace "m3" (Identity M3)))
diff --git a/testsuite/tests/ado/OrPatStrictness.stderr b/testsuite/tests/ado/OrPatStrictness.stderr
new file mode 100644
index 000000000000..70635a469567
--- /dev/null
+++ b/testsuite/tests/ado/OrPatStrictness.stderr
@@ -0,0 +1,2 @@
+m2
+m3
diff --git a/testsuite/tests/ado/OrPatStrictness.stdout b/testsuite/tests/ado/OrPatStrictness.stdout
new file mode 100644
index 000000000000..ce371b7a8231
--- /dev/null
+++ b/testsuite/tests/ado/OrPatStrictness.stdout
@@ -0,0 +1 @@
+Identity M3
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 20296770786f..182b1aa6199c 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -22,3 +22,4 @@ test('T17835', normal, compile, [''])
test('T20540', normal, compile, [''])
test('T16135', [when(compiler_debugged(),expect_broken(16135))], compile_fail, [''])
test('T22483', normal, compile, ['-Wall'])
+test('OrPatStrictness', normal, compile_and_run, [''])
diff --git a/testsuite/tests/deSugar/should_run/Or5.hs b/testsuite/tests/deSugar/should_run/Or5.hs
new file mode 100644
index 000000000000..6cdd97868813
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/Or5.hs
@@ -0,0 +1,57 @@
+{-# 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 (f4 LT True == 1)
+ print (f4 LT False == 2)
+ print (f4 EQ True == 1)
+ print (f4 EQ False == 3)
+
+ print (a3 == 3)
+ print (a4 == True)
+ print (a5 == True)
+ print (a6 == False)
+
+ print backtrack
+
+f1 x = case x of
+ 3 -> 1
+ 4 -> 2
+ 3;4;5 -> 3
+
+f2 y = case y of
+ (_:2:_ ; 1:_) | length y /= 2 -> 1
+ ([1,2] ; 1:3:_)-> 2
+ _ ; _ -> 3
+
+f3 :: (Eq a, Show a) => a -> a -> Bool
+f3 a (((== a) -> True) ; (show -> "8")) = True
+f3 _ _ = False
+
+f4 :: Ordering -> Bool -> Int
+f4 (LT; EQ) True = 1
+f4 LT False = 2
+f4 _ False = 3
+{-# NOINLINE f4 #-}
+
+a3 = (\(1 ; 2) -> 3) 1
+a4 = (\(Left 0 ; Right 1) -> True) (Right 1)
+a5 = (\(([1] ; [2, _]) ; ([3, _, _] ; [4, _, _, _])) -> True) [4, undefined, undefined, undefined]
+a6 = (\(1 ; 2 ; 3) -> False) 3
+
+backtrack :: String
+backtrack = case (True, error "backtracking") of
+ ((True, _) ; (_, True))
+ | id False -> error "inaccessible"
+ _ -> error "no backtracking"
diff --git a/testsuite/tests/deSugar/should_run/Or5.stderr b/testsuite/tests/deSugar/should_run/Or5.stderr
new file mode 100644
index 000000000000..6e16580fde92
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/Or5.stderr
@@ -0,0 +1,8 @@
+Or5: no backtracking
+CallStack (from HasCallStack):
+ error, called at Or5.hs:57:8 in main:Main
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:128:3 in ghc-internal:GHC.Internal.Exception
+
+
diff --git a/testsuite/tests/deSugar/should_run/Or5.stdout b/testsuite/tests/deSugar/should_run/Or5.stdout
new file mode 100644
index 000000000000..3c8b2d127e1d
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/Or5.stdout
@@ -0,0 +1,14 @@
+True
+True
+True
+True
+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 ce3185c2139e..874c44eddf53 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('Or5', exit_code(1), compile_and_run, [''])
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index f09e493fdd4a..c3b24cc808bb 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -37,7 +37,7 @@ check title expected got
-- See Note [Adding a language extension] in compiler/GHC/Driver/Session.hs.
expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions =
- [
+ [ "OrPatterns"
]
expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/interface-stability/template-haskell-exports.stdout b/testsuite/tests/interface-stability/template-haskell-exports.stdout
index ac5865c5f07d..07017f20bd5f 100644
--- a/testsuite/tests/interface-stability/template-haskell-exports.stdout
+++ b/testsuite/tests/interface-stability/template-haskell-exports.stdout
@@ -170,6 +170,7 @@ module Language.Haskell.TH where
| RecordWildCards
| NamedFieldPuns
| ViewPatterns
+ | OrPatterns
| GADTs
| GADTSyntax
| NPlusKPatterns
@@ -318,7 +319,7 @@ module Language.Haskell.TH where
type ParentName :: *
type ParentName = Name
type Pat :: *
- data Pat = LitP Lit | VarP Name | TupP [Pat] | UnboxedTupP [Pat] | UnboxedSumP Pat SumAlt SumArity | ConP Name [Type] [Pat] | InfixP Pat Name Pat | UInfixP Pat Name Pat | ParensP Pat | TildeP Pat | BangP Pat | AsP Name Pat | WildP | RecP Name [FieldPat] | ListP [Pat] | SigP Pat Type | ViewP Exp Pat | TypeP Type | InvisP Type
+ data Pat = LitP Lit | VarP Name | TupP [Pat] | UnboxedTupP [Pat] | UnboxedSumP Pat SumAlt SumArity | ConP Name [Type] [Pat] | InfixP Pat Name Pat | UInfixP Pat Name Pat | ParensP Pat | TildeP Pat | BangP Pat | AsP Name Pat | WildP | RecP Name [FieldPat] | ListP [Pat] | SigP Pat Type | ViewP Exp Pat | TypeP Type | InvisP Type | OrP (GHC.Internal.Base.NonEmpty Pat)
type PatQ :: *
type PatQ = Q Pat
type PatSynArgs :: *
@@ -768,6 +769,7 @@ module Language.Haskell.TH.LanguageExtensions where
| RecordWildCards
| NamedFieldPuns
| ViewPatterns
+ | OrPatterns
| GADTs
| GADTSyntax
| NPlusKPatterns
@@ -1418,6 +1420,7 @@ module Language.Haskell.TH.Lib.Internal where
notStrict :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => m GHC.Internal.TH.Syntax.Strict
numTyLit :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Num.Integer.Integer -> m GHC.Internal.TH.Syntax.TyLit
openTypeFamilyD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> [m (GHC.Internal.TH.Syntax.TyVarBndr GHC.Internal.TH.Syntax.BndrVis)] -> m GHC.Internal.TH.Syntax.FamilyResultSig -> GHC.Internal.Maybe.Maybe InjectivityAnn -> m GHC.Internal.TH.Syntax.Dec
+ orP :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Base.NonEmpty (m GHC.Internal.TH.Syntax.Pat) -> m GHC.Internal.TH.Syntax.Pat
parS :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => [[m GHC.Internal.TH.Syntax.Stmt]] -> m GHC.Internal.TH.Syntax.Stmt
parensE :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => m GHC.Internal.TH.Syntax.Exp -> m GHC.Internal.TH.Syntax.Exp
parensP :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => m GHC.Internal.TH.Syntax.Pat -> m GHC.Internal.TH.Syntax.Pat
@@ -1832,6 +1835,7 @@ module Language.Haskell.TH.Syntax where
| RecordWildCards
| NamedFieldPuns
| ViewPatterns
+ | OrPatterns
| GADTs
| GADTSyntax
| NPlusKPatterns
@@ -1984,7 +1988,7 @@ module Language.Haskell.TH.Syntax where
type ParentName :: *
type ParentName = Name
type Pat :: *
- data Pat = LitP Lit | VarP Name | TupP [Pat] | UnboxedTupP [Pat] | UnboxedSumP Pat SumAlt SumArity | ConP Name [Type] [Pat] | InfixP Pat Name Pat | UInfixP Pat Name Pat | ParensP Pat | TildeP Pat | BangP Pat | AsP Name Pat | WildP | RecP Name [FieldPat] | ListP [Pat] | SigP Pat Type | ViewP Exp Pat | TypeP Type | InvisP Type
+ data Pat = LitP Lit | VarP Name | TupP [Pat] | UnboxedTupP [Pat] | UnboxedSumP Pat SumAlt SumArity | ConP Name [Type] [Pat] | InfixP Pat Name Pat | UInfixP Pat Name Pat | ParensP Pat | TildeP Pat | BangP Pat | AsP Name Pat | WildP | RecP Name [FieldPat] | ListP [Pat] | SigP Pat Type | ViewP Exp Pat | TypeP Type | InvisP Type | OrP (GHC.Internal.Base.NonEmpty Pat)
type PatSynArgs :: *
data PatSynArgs = PrefixPatSyn [Name] | InfixPatSyn Name Name | RecordPatSyn [Name]
type PatSynDir :: *
diff --git a/testsuite/tests/parser/should_fail/Or1.hs b/testsuite/tests/parser/should_fail/Or1.hs
new file mode 100644
index 000000000000..ccabecbddfcb
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or1.hs
@@ -0,0 +1,4 @@
+module Main where
+
+main = case 1 of
+ (2 ; 3) -> True
diff --git a/testsuite/tests/parser/should_fail/Or1.stderr b/testsuite/tests/parser/should_fail/Or1.stderr
new file mode 100644
index 000000000000..b4f831a0fd52
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/Or1.stderr
@@ -0,0 +1,5 @@
+Or1.hs:4:4: error: [GHC-29847]
+ Illegal or-pattern: 2; 3
+ Suggested fix:
+ Perhaps you intended to use the ‘OrPatterns’ extension
+
diff --git a/testsuite/tests/parser/should_fail/OrPatInExprErr.hs b/testsuite/tests/parser/should_fail/OrPatInExprErr.hs
new file mode 100644
index 000000000000..c064b19fb88d
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/OrPatInExprErr.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE OrPatterns #-}
+
+module OrPatInExprErr where
+
+x = (True; False)
diff --git a/testsuite/tests/parser/should_fail/OrPatInExprErr.stderr b/testsuite/tests/parser/should_fail/OrPatInExprErr.stderr
new file mode 100644
index 000000000000..c1dd22278ae5
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/OrPatInExprErr.stderr
@@ -0,0 +1,3 @@
+OrPatInExprErr.hs:5:5: error: [GHC-66718]
+ Or pattern in expression context: (True; False)
+
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 92f39f0fc18d..88f7b35ef6a0 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -227,3 +227,5 @@ test('ListTuplePunsFail4', extra_files(['ListTuplePunsFail4.hs']), ghci_script,
test('ListTuplePunsFail5', extra_files(['ListTuplePunsFail5.hs']), ghci_script, ['ListTuplePunsFail5.script'])
test('T17879a', normal, compile_fail, [''])
test('T17879b', normal, compile_fail, [''])
+test('Or1', normal, compile_fail, [''])
+test('OrPatInExprErr', normal, compile_fail, [''])
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index b2b0114d419b..cc4544ba0283 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -103,6 +103,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', collect_compiler_stats('bytes allocated',10), 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 000000000000..2dd9673a30bf
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/pmcOrPats.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+{-# LANGUAGE OrPatterns #-}
+
+module PmcOrPats where
+
+data T = A | B
+data U = V | W
+
+g :: T -> U -> Int
+g (A;B) V = 0
+g B (V;W) = 1
+
+h A (_;W) B = 0
+h B (V;_) B = 1
+h (A;B) _ B = 2
+
+z (1;2;1) = 0
+z (3;2) = 1
+z 1 = 2
+
+careful (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) False = 1
+careful (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) (LT;GT) True = 2
+careful EQ EQ EQ EQ EQ EQ EQ EQ EQ EQ EQ EQ EQ _ = 3
diff --git a/testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr b/testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
new file mode 100644
index 000000000000..12aefbaa5856
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
@@ -0,0 +1,45 @@
+
+pmcOrPats.hs:10: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:13: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:15:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In an equation for ‘h’: h (A; B) _ B = ...
+
+pmcOrPats.hs:17: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:19:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In an equation for ‘z’: z 1 = ...
+
+pmcOrPats.hs:21:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In an equation for ‘careful’:
+ Patterns of type ‘Ordering’, ‘Ordering’, ‘Ordering’, ‘Ordering’,
+ ‘Ordering’, ‘Ordering’, ‘Ordering’, ‘Ordering’, ‘Ordering’,
+ ‘Ordering’, ‘Ordering’, ‘Ordering’, ‘Ordering’, ‘Bool’ not matched:
+ LT _ _ _ _ _ _ _ _ _ _ _ _ _
+ GT _ _ _ _ _ _ _ _ _ _ _ _ _
+ EQ LT _ _ _ _ _ _ _ _ _ _ _ _
+ EQ GT _ _ _ _ _ _ _ _ _ _ _ _
+ ...
+
+pmcOrPats.hs:21:1: warning: [GHC-61505]
+ Pattern match checker ran into -fmax-pmcheck-models=30 limit, so
+ • Redundant clauses might not be reported at all
+ • Redundant clauses might be reported as inaccessible
+ • Patterns reported as unmatched might actually be matched
+ Suggested fix:
+ Increase the limit or resolve the warnings to suppress this message.
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index c9ef4a04312a..f95bed329ea4 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: PprExportWarn
PprExportWarn:
$(CHECK_PPR) $(LIBDIR) PprExportWarn.hs
diff --git a/testsuite/tests/printer/PprOrPat.hs b/testsuite/tests/printer/PprOrPat.hs
new file mode 100644
index 000000000000..b16351d55f9b
--- /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
+ 4 ; 5
+ ( {- 01-}
+ {- 12 -} [4, 5] ; [6,7] {-test-} ; [_,2]
+ ) -> False
+
+pattern A <- (({-test-} reverse -> {-e-}( [2,1] ; {-1-} 0:_ )), id -> [])
+b = case [1,2] of A -> True
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index efdc37b01ec3..4b49614aba8e 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('PprExportWarn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprExportWarn'])
test('PprInstanceWarn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprInstanceWarn'])
diff --git a/testsuite/tests/rename/should_fail/Or3.hs b/testsuite/tests/rename/should_fail/Or3.hs
new file mode 100644
index 000000000000..7bb0e5b3ba30
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/Or3.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE OrPatterns #-}
+
+module Or3 where
+
+f x = case x of
+ (Left a; Right (a,b)) -> a
+
+g x = case x of
+ (_; (x; _)) -> x
+
+h x = case x of
+ (Just @y 3; Nothing) -> 2
diff --git a/testsuite/tests/rename/should_fail/Or3.stderr b/testsuite/tests/rename/should_fail/Or3.stderr
new file mode 100644
index 000000000000..ff1b54eee48f
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/Or3.stderr
@@ -0,0 +1,9 @@
+
+Or3.hs:6:4: error: [GHC-81303]
+ An or-pattern may not bind term or type variables such as ‘a’ or ‘b’
+
+Or3.hs:9:8: error: [GHC-81303]
+ An or-pattern may not bind term or type variables such as ‘x’
+
+Or3.hs:12:4: error: [GHC-81303]
+ An or-pattern may not bind term or type variables such as ‘y’
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 96460bc95e4e..8f02e1b70a78 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -222,6 +222,7 @@ test('T23740g', normal, compile_fail, [''])
test('T23740h', normal, compile_fail, [''])
test('T23740i', req_th, compile_fail, [''])
test('T23740j', normal, compile_fail, [''])
+test('Or3', normal, compile_fail, [''])
test('T23570', [extra_files(['T23570_aux.hs'])], multimod_compile_fail, ['T23570', '-v0'])
test('T23570b', [extra_files(['T23570_aux.hs'])], multimod_compile, ['T23570b', '-v0'])
test('T17594b', req_th, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_fail/Or4.hs b/testsuite/tests/typecheck/should_fail/Or4.hs
new file mode 100644
index 000000000000..cb50d470c3e3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/Or4.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OrPatterns, 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 (G2; G1) = 3
+
+data GADT a where
+ IsInt1 :: GADT Int
+ IsInt2 :: GADT Int
+
+foo :: a -> GADT a -> a
+foo x (IsInt1 {}; IsInt2 {}) = x + 1
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_fail/Or4.stderr b/testsuite/tests/typecheck/should_fail/Or4.stderr
new file mode 100644
index 000000000000..7daa0ea872e2
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/Or4.stderr
@@ -0,0 +1,18 @@
+
+Or4.hs:11:16: error: [GHC-39999]
+ • No instance for ‘Num a’ arising from the literal ‘3’
+ Possible fix:
+ add (Num a) to the context of
+ the type signature for:
+ bar :: forall a. G a -> a
+ • In the expression: 3
+ In an equation for ‘bar’: bar (G2; G1) = 3
+
+Or4.hs:18:34: error: [GHC-39999]
+ • No instance for ‘Num a’ arising from a use of ‘+’
+ Possible fix:
+ add (Num a) to the context of
+ the type signature for:
+ foo :: forall a. a -> GADT a -> a
+ • In the expression: x + 1
+ In an equation for ‘foo’: foo x (IsInt1 {}; IsInt2 {}) = x + 1
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index eedbc5c23018..9670111fc479 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -666,6 +666,7 @@ test('MissingDefaultMethodBinding', normal, compile_fail, [''])
test('T21447', normal, compile_fail, [''])
test('T21530a', normal, compile_fail, [''])
test('T21530b', normal, compile_fail, [''])
+test('Or4', normal, compile_fail, [''])
test('T22570', normal, compile_fail, [''])
test('T22645', normal, compile_fail, [''])
test('T20666', normal, compile_fail, [''])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 35e6c1a661a1..3ef33a20b3c0 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -64,6 +64,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 qualified Data.Map.Strict as Map
import Data.Maybe ( isJust, mapMaybe )
import Data.Void
@@ -4717,6 +4718,10 @@ instance ExactPrint (Pat GhcPs) where
an3 <- markEpAnnL an2 lsumPatParens AnnClosePH
return (SumPat an3 pat' alt arity)
+ exact (OrPat an pats) = do
+ pats' <- markAnnotated (NE.toList pats)
+ return (OrPat an (NE.fromList pats'))
+
exact (ConPat an con details) = do
(an', con', details') <- exactUserCon an con details
return (ConPat an' con' details')
--
GitLab