summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJakob Bruenker <jakob.bruenker@gmail.com>2022-03-21 00:14:25 +0100
committerJakob Bruenker <jakob.bruenker@gmail.com>2022-04-01 20:31:08 +0200
commit32070e6c2e1b4b7c32530a9566fe14543791f9a6 (patch)
treef0913ef2a69fd660542723ec07240167dbd37961
parentd85c7dcb7c457efc23b20ac8f4e4ae88bae5b050 (diff)
downloadhaskell-32070e6c2e1b4b7c32530a9566fe14543791f9a6.tar.gz
Implement \cases (Proposal 302)
This commit implements proposal 302: \cases - Multi-way lambda expressions. This adds a new expression heralded by \cases, which works exactly like \case, but can match multiple apats instead of a single pat. Updates submodule haddock to support the ITlcases token. Closes #20768
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs78
-rw-r--r--compiler/GHC/Hs/Expr.hs94
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs2
-rw-r--r--compiler/GHC/Hs/Utils.hs11
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs202
-rw-r--r--compiler/GHC/HsToCore/Binds.hs4
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs30
-rw-r--r--compiler/GHC/HsToCore/Expr.hs14
-rw-r--r--compiler/GHC/HsToCore/Match.hs37
-rw-r--r--compiler/GHC/HsToCore/Match.hs-boot2
-rw-r--r--compiler/GHC/HsToCore/Pmc.hs29
-rw-r--r--compiler/GHC/HsToCore/Pmc/Utils.hs30
-rw-r--r--compiler/GHC/HsToCore/Quote.hs9
-rw-r--r--compiler/GHC/HsToCore/Utils.hs1
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs4
-rw-r--r--compiler/GHC/Parser.y104
-rw-r--r--compiler/GHC/Parser/Annotation.hs1
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs25
-rw-r--r--compiler/GHC/Parser/Errors/Types.hs9
-rw-r--r--compiler/GHC/Parser/Lexer.x12
-rw-r--r--compiler/GHC/Parser/PostProcess.hs52
-rw-r--r--compiler/GHC/Rename/Bind.hs59
-rw-r--r--compiler/GHC/Rename/Expr.hs15
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs8
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs9
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs150
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs41
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs47
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs8
-rw-r--r--compiler/GHC/ThToHs.hs14
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs127
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs24
-rw-r--r--docs/users_guide/9.4.1-notes.rst6
-rw-r--r--docs/users_guide/exts/empty_case.rst5
-rw-r--r--docs/users_guide/exts/lambda_case.rst19
-rwxr-xr-xlibraries/base/GHC/Exts.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs6
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs5
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs16
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs2
-rw-r--r--testsuite/tests/arrows/should_fail/T20768_arrow_fail.hs29
-rw-r--r--testsuite/tests/arrows/should_fail/T20768_arrow_fail.stderr66
-rw-r--r--testsuite/tests/arrows/should_fail/all.T1
-rw-r--r--testsuite/tests/arrows/should_run/ArrowLambdaCase.hs22
-rw-r--r--testsuite/tests/arrows/should_run/ArrowLambdaCase.stdout2
-rw-r--r--testsuite/tests/corelint/T21115b.stderr6
-rw-r--r--testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/T16270.stderr17
-rw-r--r--testsuite/tests/perf/compiler/hard_hole_fits.hs3
-rw-r--r--testsuite/tests/perf/compiler/hard_hole_fits.stderr8
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr2
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr8
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase003.stderr6
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr12
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr4
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr10
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr8
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr4
-rw-r--r--testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr12
-rw-r--r--testsuite/tests/printer/Ppr020.hs8
-rw-r--r--testsuite/tests/printer/PprArrowLambdaCase.hs8
-rw-r--r--testsuite/tests/rep-poly/RepPolyMatch.stderr2
-rw-r--r--testsuite/tests/typecheck/should_compile/hard_hole_fits.hs3
-rw-r--r--testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr2
-rw-r--r--testsuite/tests/typecheck/should_fail/T20768_fail.hs12
-rw-r--r--testsuite/tests/typecheck/should_fail/T20768_fail.stderr31
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T1
-rw-r--r--testsuite/tests/typecheck/should_run/T20768.hs24
-rw-r--r--testsuite/tests/typecheck/should_run/T20768.stdout4
-rwxr-xr-xtestsuite/tests/typecheck/should_run/all.T1
-rw-r--r--utils/check-exact/ExactPrint.hs23
-rw-r--r--utils/check-exact/Lookup.hs1
m---------utils/haddock0
75 files changed, 1096 insertions, 568 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index f5dbc4fdc9..98f8dacde0 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -54,7 +54,7 @@ templateHaskellNames = [
-- Exp
varEName, conEName, litEName, appEName, appTypeEName, infixEName,
infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
- tupEName, unboxedTupEName, unboxedSumEName,
+ lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,
condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
@@ -285,7 +285,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey
-- data Exp = ...
varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
- sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
+ sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,
unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name
@@ -300,6 +300,7 @@ sectionLName = libFun (fsLit "sectionL") sectionLIdKey
sectionRName = libFun (fsLit "sectionR") sectionRIdKey
lamEName = libFun (fsLit "lamE") lamEIdKey
lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
+lamCasesEName = libFun (fsLit "lamCasesE") lamCasesEIdKey
tupEName = libFun (fsLit "tupE") tupEIdKey
unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
@@ -813,8 +814,8 @@ clauseIdKey = mkPreludeMiscIdUnique 262
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,
- tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
- letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
+ lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,
+ multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,
@@ -830,52 +831,53 @@ sectionLIdKey = mkPreludeMiscIdUnique 277
sectionRIdKey = mkPreludeMiscIdUnique 278
lamEIdKey = mkPreludeMiscIdUnique 279
lamCaseEIdKey = mkPreludeMiscIdUnique 280
-tupEIdKey = mkPreludeMiscIdUnique 281
-unboxedTupEIdKey = mkPreludeMiscIdUnique 282
-unboxedSumEIdKey = mkPreludeMiscIdUnique 283
-condEIdKey = mkPreludeMiscIdUnique 284
-multiIfEIdKey = mkPreludeMiscIdUnique 285
-letEIdKey = mkPreludeMiscIdUnique 286
-caseEIdKey = mkPreludeMiscIdUnique 287
-doEIdKey = mkPreludeMiscIdUnique 288
-compEIdKey = mkPreludeMiscIdUnique 289
-fromEIdKey = mkPreludeMiscIdUnique 290
-fromThenEIdKey = mkPreludeMiscIdUnique 291
-fromToEIdKey = mkPreludeMiscIdUnique 292
-fromThenToEIdKey = mkPreludeMiscIdUnique 293
-listEIdKey = mkPreludeMiscIdUnique 294
-sigEIdKey = mkPreludeMiscIdUnique 295
-recConEIdKey = mkPreludeMiscIdUnique 296
-recUpdEIdKey = mkPreludeMiscIdUnique 297
-staticEIdKey = mkPreludeMiscIdUnique 298
-unboundVarEIdKey = mkPreludeMiscIdUnique 299
-labelEIdKey = mkPreludeMiscIdUnique 300
-implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
-mdoEIdKey = mkPreludeMiscIdUnique 302
-getFieldEIdKey = mkPreludeMiscIdUnique 303
-projectionEIdKey = mkPreludeMiscIdUnique 304
+lamCasesEIdKey = mkPreludeMiscIdUnique 281
+tupEIdKey = mkPreludeMiscIdUnique 282
+unboxedTupEIdKey = mkPreludeMiscIdUnique 283
+unboxedSumEIdKey = mkPreludeMiscIdUnique 284
+condEIdKey = mkPreludeMiscIdUnique 285
+multiIfEIdKey = mkPreludeMiscIdUnique 286
+letEIdKey = mkPreludeMiscIdUnique 287
+caseEIdKey = mkPreludeMiscIdUnique 288
+doEIdKey = mkPreludeMiscIdUnique 289
+compEIdKey = mkPreludeMiscIdUnique 290
+fromEIdKey = mkPreludeMiscIdUnique 291
+fromThenEIdKey = mkPreludeMiscIdUnique 292
+fromToEIdKey = mkPreludeMiscIdUnique 293
+fromThenToEIdKey = mkPreludeMiscIdUnique 294
+listEIdKey = mkPreludeMiscIdUnique 295
+sigEIdKey = mkPreludeMiscIdUnique 296
+recConEIdKey = mkPreludeMiscIdUnique 297
+recUpdEIdKey = mkPreludeMiscIdUnique 298
+staticEIdKey = mkPreludeMiscIdUnique 299
+unboundVarEIdKey = mkPreludeMiscIdUnique 300
+labelEIdKey = mkPreludeMiscIdUnique 301
+implicitParamVarEIdKey = mkPreludeMiscIdUnique 302
+mdoEIdKey = mkPreludeMiscIdUnique 303
+getFieldEIdKey = mkPreludeMiscIdUnique 304
+projectionEIdKey = mkPreludeMiscIdUnique 305
-- type FieldExp = ...
fieldExpIdKey :: Unique
-fieldExpIdKey = mkPreludeMiscIdUnique 305
+fieldExpIdKey = mkPreludeMiscIdUnique 306
-- data Body = ...
guardedBIdKey, normalBIdKey :: Unique
-guardedBIdKey = mkPreludeMiscIdUnique 306
-normalBIdKey = mkPreludeMiscIdUnique 307
+guardedBIdKey = mkPreludeMiscIdUnique 307
+normalBIdKey = mkPreludeMiscIdUnique 308
-- data Guard = ...
normalGEIdKey, patGEIdKey :: Unique
-normalGEIdKey = mkPreludeMiscIdUnique 308
-patGEIdKey = mkPreludeMiscIdUnique 309
+normalGEIdKey = mkPreludeMiscIdUnique 309
+patGEIdKey = mkPreludeMiscIdUnique 310
-- data Stmt = ...
bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
-bindSIdKey = mkPreludeMiscIdUnique 310
-letSIdKey = mkPreludeMiscIdUnique 311
-noBindSIdKey = mkPreludeMiscIdUnique 312
-parSIdKey = mkPreludeMiscIdUnique 313
-recSIdKey = mkPreludeMiscIdUnique 314
+bindSIdKey = mkPreludeMiscIdUnique 311
+letSIdKey = mkPreludeMiscIdUnique 312
+noBindSIdKey = mkPreludeMiscIdUnique 313
+parSIdKey = mkPreludeMiscIdUnique 314
+recSIdKey = mkPreludeMiscIdUnique 315
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index e4ce67d5cf..6020950c11 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -71,6 +71,8 @@ import qualified Data.Data as Data (Fixity(..))
import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Foldable ( toList )
+import Data.List (uncons)
+import Data.Bifunctor (first)
{- *********************************************************************
* *
@@ -322,6 +324,7 @@ type instance XLitE (GhcPass _) = EpAnnCO
type instance XLam (GhcPass _) = NoExtField
type instance XLamCase (GhcPass _) = EpAnn [AddEpAnn]
+
type instance XApp (GhcPass _) = EpAnnCO
type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives
@@ -643,8 +646,8 @@ ppr_expr (ExplicitSum _ alt arity expr)
ppr_expr (HsLam _ matches)
= pprMatches matches
-ppr_expr (HsLamCase _ matches)
- = sep [ sep [text "\\case"],
+ppr_expr (HsLamCase _ lc_variant matches)
+ = sep [ sep [lamCaseKeyword lc_variant],
nest 2 (pprMatches matches) ]
ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))
@@ -1229,8 +1232,8 @@ ppr_cmd (HsCmdCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), text "of"],
nest 2 (pprMatches matches) ]
-ppr_cmd (HsCmdLamCase _ matches)
- = sep [ text "\\case", nest 2 (pprMatches matches) ]
+ppr_cmd (HsCmdLamCase _ lc_variant matches)
+ = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ]
ppr_cmd (HsCmdIf _ _ e ct ce)
= sep [hsep [text "if", nest 2 (ppr e), text "then"],
@@ -1406,6 +1409,14 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
LambdaExpr -> (char '\\', pats)
+ -- We don't simply return (empty, pats) to avoid introducing an
+ -- additional `nest 2` via the empty herald
+ LamCaseAlt LamCases ->
+ maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)
+
+ ArrowMatchCtxt (ArrowLamCaseAlt LamCases) ->
+ maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)
+
ArrowMatchCtxt KappaExpr -> (char '\\', pats)
ArrowMatchCtxt ProcExpr -> (text "proc", pats)
@@ -1929,23 +1940,30 @@ pp_dotdot = text " .. "
-}
instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
- ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
- ppr LambdaExpr = text "LambdaExpr"
- ppr CaseAlt = text "CaseAlt"
- ppr IfAlt = text "IfAlt"
- ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c
- ppr PatBindRhs = text "PatBindRhs"
- ppr PatBindGuards = text "PatBindGuards"
- ppr RecUpd = text "RecUpd"
- ppr (StmtCtxt _) = text "StmtCtxt _"
- ppr ThPatSplice = text "ThPatSplice"
- ppr ThPatQuote = text "ThPatQuote"
- ppr PatSyn = text "PatSyn"
+ ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
+ ppr LambdaExpr = text "LambdaExpr"
+ ppr CaseAlt = text "CaseAlt"
+ ppr (LamCaseAlt lc_variant) = text "LamCaseAlt" <+> ppr lc_variant
+ ppr IfAlt = text "IfAlt"
+ ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c
+ ppr PatBindRhs = text "PatBindRhs"
+ ppr PatBindGuards = text "PatBindGuards"
+ ppr RecUpd = text "RecUpd"
+ ppr (StmtCtxt _) = text "StmtCtxt _"
+ ppr ThPatSplice = text "ThPatSplice"
+ ppr ThPatQuote = text "ThPatQuote"
+ ppr PatSyn = text "PatSyn"
+
+instance Outputable LamCaseVariant where
+ ppr = text . \case
+ LamCase -> "LamCase"
+ LamCases -> "LamCases"
instance Outputable HsArrowMatchContext where
- ppr ProcExpr = text "ProcExpr"
- ppr ArrowCaseAlt = text "ArrowCaseAlt"
- ppr KappaExpr = text "KappaExpr"
+ ppr ProcExpr = text "ProcExpr"
+ ppr ArrowCaseAlt = text "ArrowCaseAlt"
+ ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant
+ ppr KappaExpr = text "KappaExpr"
-----------------
@@ -1956,27 +1974,29 @@ instance OutputableBndrId p
-- Used to generate the string for a *runtime* error message
matchContextErrString :: OutputableBndrId p
=> HsMatchContext (GhcPass p) -> SDoc
-matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
-matchContextErrString CaseAlt = text "case"
-matchContextErrString IfAlt = text "multi-way if"
-matchContextErrString PatBindRhs = text "pattern binding"
-matchContextErrString PatBindGuards = text "pattern binding guards"
-matchContextErrString RecUpd = text "record update"
-matchContextErrString LambdaExpr = text "lambda"
-matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c
-matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
-matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"
+matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
+matchContextErrString CaseAlt = text "case"
+matchContextErrString (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant
+matchContextErrString IfAlt = text "multi-way if"
+matchContextErrString PatBindRhs = text "pattern binding"
+matchContextErrString PatBindGuards = text "pattern binding guards"
+matchContextErrString RecUpd = text "record update"
+matchContextErrString LambdaExpr = text "lambda"
+matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c
+matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
+matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"
matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
matchArrowContextErrString :: HsArrowMatchContext -> SDoc
-matchArrowContextErrString ProcExpr = text "proc"
-matchArrowContextErrString ArrowCaseAlt = text "case"
-matchArrowContextErrString KappaExpr = text "kappa"
+matchArrowContextErrString ProcExpr = text "proc"
+matchArrowContextErrString ArrowCaseAlt = text "case"
+matchArrowContextErrString (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant
+matchArrowContextErrString KappaExpr = text "kappa"
matchDoContextErrString :: HsDoFlavour -> SDoc
matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 4952256baf..be1fd40ce0 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -99,7 +99,7 @@ hsExprType (HsIPVar v _) = dataConCantHappen v
hsExprType (HsOverLit _ lit) = overLitType lit
hsExprType (HsLit _ lit) = hsLitType lit
hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
-hsExprType (HsLamCase _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
+hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x
hsExprType (OpApp v _ _ _) = dataConCantHappen v
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index ef5ad6e494..8e2980edaa 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -41,7 +41,7 @@ module GHC.Hs.Utils(
mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
- mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
+ mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,
@@ -213,6 +213,15 @@ mkMatchGroup origin matches = MG { mg_ext = noExtField
, mg_alts = matches
, mg_origin = origin }
+mkLamCaseMatchGroup :: AnnoBody p body
+ => Origin
+ -> LamCaseVariant
+ -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
+ -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
+mkLamCaseMatchGroup origin lc_variant (L l matches)
+ = mkMatchGroup origin (L l $ map fixCtxt matches)
+ where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant}
+
mkLocatedList :: Semigroup a
=> [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
mkLocatedList [] = noLocA []
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 3d93e0b7a5..fffa3347b0 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -1,5 +1,5 @@
-
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -466,6 +466,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
{-
+Note [Desugaring HsCmdCase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
Case commands are treated in much the same way as if commands
(see above) except that there are more alternatives. For example
@@ -492,74 +494,87 @@ case bodies, containing the following fields:
bodies with |||.
-}
-dsCmd ids local_vars stack_ty res_ty
- (HsCmdCase _ exp (MG { mg_alts = L l matches
- , mg_ext = MatchGroupTc arg_tys _
- , mg_origin = origin }))
- env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do
stack_id <- newSysLocalDs Many stack_ty
-
- -- Extract and desugar the leaf commands in the case, building tuple
- -- expressions that will (after tagging) replace these leaves
-
- let
- leaves = concatMap leavesMatch matches
- make_branch (leaf, bound_vars) = do
- (core_leaf, _fvs, leaf_ids)
- <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
- res_ty leaf
- return ([mkHsEnvStackExpr leaf_ids stack_id],
- envStackType leaf_ids stack_ty,
- core_leaf)
-
- branches <- mapM make_branch leaves
- either_con <- dsLookupTyCon eitherTyConName
- left_con <- dsLookupDataCon leftDataConName
- right_con <- dsLookupDataCon rightDataConName
- let
- left_id = mkConLikeTc (RealDataCon left_con)
- right_id = mkConLikeTc (RealDataCon right_con)
- left_expr ty1 ty2 e = noLocA $ HsApp noComments
- (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLocA $ HsApp noComments
- (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-
- -- Prefix each tuple with a distinct series of Left's and Right's,
- -- in a balanced way, keeping track of the types.
-
- merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)
- -> ([LHsExpr GhcTc], Type, CoreExpr)
- -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ
- merge_branches (builds1, in_ty1, core_exp1)
- (builds2, in_ty2, core_exp2)
- = (map (left_expr in_ty1 in_ty2) builds1 ++
- map (right_expr in_ty1 in_ty2) builds2,
- mkTyConApp either_con [in_ty1, in_ty2],
- do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
- (leaves', sum_ty, core_choices) = foldb merge_branches branches
-
- -- Replace the commands in the case with these tagged tuples,
- -- yielding a HsExpr Id we can feed to dsExpr.
-
- (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+ (match', core_choices)
+ <- dsCases ids local_vars stack_id stack_ty res_ty match
+ let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'
in_ty = envStackType env_ids stack_ty
- core_body <- dsExpr (HsCase noExtField exp
- (MG { mg_alts = L l matches'
- , mg_ext = MatchGroupTc arg_tys sum_ty
- , mg_origin = origin }))
- -- Note that we replace the HsCase result type by sum_ty,
- -- which is the type of matches'
+ core_body <- dsExpr (HsCase noExtField exp match')
core_matches <- matchEnvStack env_ids stack_id core_body
return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
+{-
+\cases and \case are desugared analogously to a case command (see above).
+For example
+
+ \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 }
+
+is translated to
+
+ premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of
+ p1 q1 -> (Left (Left (xs1), stk))
+ p2 q2 -> Left ((Right (xs2), stk))
+ p3 q3 -> Right ((xs3), stk))
+ ((c1 ||| c2) ||| c3)
+
+(cases...of is hypothetical notation that works like case...of but with
+multiple scrutinees)
+
+-}
dsCmd ids local_vars stack_ty res_ty
- (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do
- arg_id <- newSysLocalDs arg_mult arg_ty
- let case_cmd = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg
- dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids
+ (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )
+ env_ids = do
+ arg_ids <- newSysLocalsDs arg_tys
+
+ let match_ctxt = ArrowLamCaseAlt lc_variant
+ pat_vars = mkVarSet arg_ids
+ local_vars' = pat_vars `unionVarSet` local_vars
+ (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty
+
+ -- construct and desugar a case expression with multiple scrutinees
+ (core_body, free_vars, env_ids') <- trimInput \env_ids -> do
+ stack_id <- newSysLocalDs Many stack_ty'
+ (match', core_choices)
+ <- dsCases ids local_vars' stack_id stack_ty' res_ty match
+
+ let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'
+ in_ty = envStackType env_ids stack_ty'
+ discrims = map nlHsVar arg_ids
+ (discrim_vars, matching_code)
+ <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match'
+ core_body <- flip (bind_vars discrim_vars) matching_code <$>
+ traverse dsLExpr discrims
+
+ core_matches <- matchEnvStack env_ids stack_id core_body
+ return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
+ exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars')
+
+ param_ids <- mapM (newSysLocalDs Many) pat_tys
+ stack_id' <- newSysLocalDs Many stack_ty'
+
+ -- the expression is built from the inside out, so the actions
+ -- are presented in reverse order
+
+ let -- build a new environment, plus what's left of the stack
+ core_expr = buildEnvStack env_ids' stack_id'
+ in_ty = envStackType env_ids stack_ty
+ in_ty' = envStackType env_ids' stack_ty'
+
+ -- bind the scrutinees to the parameters
+ let match_code = bind_vars arg_ids (map Var param_ids) core_expr
+
+ -- match the parameters against the top of the old stack
+ (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
+ -- match the old environment and stack against the input
+ select_code <- matchEnvStack env_ids stack_id param_code
+ return (do_premap ids in_ty in_ty' res_ty select_code core_body,
+ free_vars `uniqDSetMinusUniqSet` pat_vars)
+ where
+ bind_vars vars exprs expr = foldr (uncurry bindNonRec) expr $ zip vars exprs
-- D; ys |-a cmd : stk --> t
-- ----------------------------------
@@ -680,7 +695,7 @@ trimInput build_arrow
(core_cmd, free_vars) <- build_arrow env_ids
return (core_cmd, free_vars, dVarSetElems free_vars))
--- Desugaring for both HsCmdLam and HsCmdLamCase.
+-- Desugaring for both HsCmdLam
--
-- D; ys |-a cmd : stk t'
-- -----------------------------------------------
@@ -726,6 +741,71 @@ dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do
return (do_premap ids in_ty in_ty' res_ty select_code core_body,
free_vars `uniqDSetMinusUniqSet` pat_vars)
+-- Used for case and \case(s)
+-- See Note [Desugaring HsCmdCase]
+dsCases :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> Id -- stack id
+ -> Type -- type of the stack (right-nested tuple)
+ -> Type -- return type of the command
+ -> MatchGroup GhcTc (LHsCmd GhcTc) -- match group to desugar
+ -> DsM (MatchGroup GhcTc (LHsExpr GhcTc), -- match group with choice tree
+ CoreExpr) -- desugared choices
+dsCases ids local_vars stack_id stack_ty res_ty
+ (MG { mg_alts = L l matches
+ , mg_ext = MatchGroupTc arg_tys _
+ , mg_origin = origin }) = do
+
+ -- Extract and desugar the leaf commands in the case, building tuple
+ -- expressions that will (after tagging) replace these leaves
+
+ let leaves = concatMap leavesMatch matches
+ make_branch (leaf, bound_vars) = do
+ (core_leaf, _fvs, leaf_ids)
+ <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
+ res_ty leaf
+ return ([mkHsEnvStackExpr leaf_ids stack_id],
+ envStackType leaf_ids stack_ty,
+ core_leaf)
+
+ branches <- mapM make_branch leaves
+ either_con <- dsLookupTyCon eitherTyConName
+ left_con <- dsLookupDataCon leftDataConName
+ right_con <- dsLookupDataCon rightDataConName
+ let
+ left_id = mkConLikeTc (RealDataCon left_con)
+ right_id = mkConLikeTc (RealDataCon right_con)
+ left_expr ty1 ty2 e = noLocA $ HsApp noComments
+ (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLocA $ HsApp noComments
+ (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+
+ -- Prefix each tuple with a distinct series of Left's and Right's,
+ -- in a balanced way, keeping track of the types.
+
+ merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)
+ -> ([LHsExpr GhcTc], Type, CoreExpr)
+ -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ
+ merge_branches (builds1, in_ty1, core_exp1)
+ (builds2, in_ty2, core_exp2)
+ = (map (left_expr in_ty1 in_ty2) builds1 ++
+ map (right_expr in_ty1 in_ty2) builds2,
+ mkTyConApp either_con [in_ty1, in_ty2],
+ do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+ (leaves', sum_ty, core_choices) = foldb merge_branches branches
+
+ -- Replace the commands in the case with these tagged tuples,
+ -- yielding a HsExpr Id we can feed to dsExpr.
+
+ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+
+ -- Note that we replace the MatchGroup result type by sum_ty,
+ -- which is the type of matches'
+ return (MG { mg_alts = L l matches'
+ , mg_ext = MatchGroupTc arg_tys sum_ty
+ , mg_origin = origin },
+ core_choices)
+
{-
Translation of command judgements of the form
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 793f8c9ffb..9da2ecbc02 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -164,9 +164,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
-- addTyCs: Add type evidence to the refinement type
-- predicate of the coverage checker
-- See Note [Long-distance information] in "GHC.HsToCore.Pmc"
- matchWrapper
- (mkPrefixFunRhs (L loc (idName fun)))
- Nothing matches
+ matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches
; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 96439a837d..f2948cee5e 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -536,19 +536,19 @@ addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
addTickHsExpr e@(HsUnboundVar {}) = return e
addTickHsExpr e@(HsRecSel _ (FieldOcc id _)) = do freeVar id; return e
-addTickHsExpr e@(HsIPVar {}) = return e
-addTickHsExpr e@(HsOverLit {}) = return e
-addTickHsExpr e@(HsOverLabel{}) = return e
-addTickHsExpr e@(HsLit {}) = return e
-addTickHsExpr (HsLam x mg) = liftM (HsLam x)
- (addTickMatchGroup True mg)
-addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
- (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
- (addTickLHsExpr e2)
-addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
- (addTickLHsExprNever e)
- (return ty)
+addTickHsExpr e@(HsIPVar {}) = return e
+addTickHsExpr e@(HsOverLit {}) = return e
+addTickHsExpr e@(HsOverLabel{}) = return e
+addTickHsExpr e@(HsLit {}) = return e
+addTickHsExpr (HsLam x mg) = liftM (HsLam x)
+ (addTickMatchGroup True mg)
+addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)
+ (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
+ (addTickLHsExprNever e)
+ (return ty)
addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp
(return fix)
@@ -891,8 +891,8 @@ addTickHsCmd (HsCmdCase x e mgs) =
liftM2 (HsCmdCase x)
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdLamCase x mgs) =
- liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsCmdLamCase x lc_variant mgs) =
+ liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs)
addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
liftM3 (HsCmdIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 8820d68a86..18e7cfbb8a 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -195,8 +195,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun
, fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed
- = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
- Nothing matches
+ = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches
; massert (null args) -- Functions aren't lifted
; massert (isIdHsWrapper co_fn)
; let rhs' = mkOptTickBox tick rhs
@@ -300,11 +299,10 @@ dsExpr (NegApp _ expr neg_expr)
; dsSyntaxExpr neg_expr [expr'] }
dsExpr (HsLam _ a_Match)
- = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
+ = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match
-dsExpr (HsLamCase _ matches)
- = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
- ; return $ Lam discrim_var matching_code }
+dsExpr (HsLamCase _ lc_variant matches)
+ = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches
dsExpr e@(HsApp _ fun arg)
= do { fun' <- dsLExpr fun
@@ -356,7 +354,7 @@ dsExpr (HsPragE _ prag expr) =
dsExpr (HsCase _ discrim matches)
= do { core_discrim <- dsLExpr discrim
- ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
+ ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
@@ -606,7 +604,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields
-- constructor arguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code)
- <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]
+ <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates]
(MG { mg_alts = noLocA alts
, mg_ext = MatchGroupTc [unrestricted in_ty] out_ty
, mg_origin = FromSource
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 8fcb150329..5c45d9b705 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -708,15 +708,32 @@ Call @match@ with all of this information!
\end{enumerate}
-}
+-- Note [matchWrapper scrutinees]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- There are three possible cases for matchWrapper's scrutinees argument:
+--
+-- 1. Nothing Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee
+-- The MatchGroup may have matchGroupArity of 0 or more. Examples:
+-- f p1 q1 = ... -- matchGroupArity 2
+-- f p2 q2 = ...
+--
+-- \cases | g1 -> ... -- matchGroupArity 0
+-- | g2 -> ...
+--
+-- 2. Just [e] Used for HsCase, RecordUpd; exactly one scrutinee
+-- The MatchGroup has matchGroupArity of exactly 1. Example:
+-- case e of p1 -> e1 -- matchGroupArity 1
+-- p2 -> e2
+--
+-- 3. Just es Used for HsCmdLamCase; zero or more scrutinees
+-- The MatchGroup has matchGroupArity of (length es). Example:
+-- \cases p1 q1 -> returnA -< ... -- matchGroupArity 2
+-- p2 q2 -> ...
+
matchWrapper
:: HsMatchContext GhcRn -- ^ For shadowing warning messages
- -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr
- -- case scrut of { p1 -> e1 ... }
- -- (and in this case the MatchGroup will
- -- have all singleton patterns)
- -- Nothing for a function definition
- -- f p1 q1 = ... -- No "scrutinee"
- -- f p2 q2 = ... -- in this case
+ -> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s)
+ -- see Note [matchWrapper scrutinees]
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
-> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match')
@@ -744,7 +761,7 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
-}
-matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
+matchWrapper ctxt scrs (MG { mg_alts = L _ matches
, mg_ext = MatchGroupTc arg_tys rhs_ty
, mg_origin = origin })
= do { dflags <- getDynFlags
@@ -762,7 +779,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
- then addHsScrutTmCs mb_scr new_vars $
+ then addHsScrutTmCs (concat scrs) new_vars $
-- See Note [Long-distance information]
pmcMatches (DsMatchContext ctxt locn) new_vars matches
else pure (initNablasMatches matches)
@@ -872,7 +889,7 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
; locn <- getSrcSpanDs
-- Pattern match check warnings
; when (isMatchContextPmChecked dflags FromSource ctx) $
- addCoreScrutTmCs mb_scrut [var] $
+ addCoreScrutTmCs (maybeToList mb_scrut) [var] $
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
index e163a0bde2..3e969e922d 100644
--- a/compiler/GHC/HsToCore/Match.hs-boot
+++ b/compiler/GHC/HsToCore/Match.hs-boot
@@ -15,7 +15,7 @@ match :: [Id]
matchWrapper
:: HsMatchContext GhcRn
- -> Maybe (LHsExpr GhcTc)
+ -> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index 0de7ab0a15..c810834c64 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -419,24 +419,25 @@ addTyCs origin ev_vars m = do
addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))
m
--- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment
--- when checking a case expression:
+-- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment,
+-- e.g. when checking a case expression:
-- case e of x { matches }
-- When checking matches we record that (x ~ e) where x is the initial
-- uncovered. All matches will have to satisfy this equality.
-addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a
-addCoreScrutTmCs Nothing _ k = k
-addCoreScrutTmCs (Just scr) [x] k =
- flip locallyExtendPmNablas k $ \nablas ->
+-- This is also used for the Arrows \cases command, where these equalities have
+-- to be added for multiple scrutinees rather than just one.
+addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a
+addCoreScrutTmCs [] _ k = k
+addCoreScrutTmCs (scr:scrs) (x:xs) k =
+ flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->
addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))
-addCoreScrutTmCs _ _ _ = panic "addCoreScrutTmCs: scrutinee, but more than one match id"
-
--- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.
-addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
-addHsScrutTmCs Nothing _ k = k
-addHsScrutTmCs (Just scr) vars k = do
- scr_e <- dsLExpr scr
- addCoreScrutTmCs (Just scr_e) vars k
+addCoreScrutTmCs _ _ _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ"
+
+-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.
+addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
+addHsScrutTmCs scrs vars k = do
+ scr_es <- traverse dsLExpr scrs
+ addCoreScrutTmCs scr_es vars k
{- Note [Long-distance information]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
index c79c1025d6..b7279e24b2 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ b/compiler/GHC/HsToCore/Pmc/Utils.hs
@@ -82,26 +82,28 @@ redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags
-- via which 'WarningFlag' it's controlled.
-- Returns 'Nothing' if check is not supported.
exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
-exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
-exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag FunRhs{} = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag LamCaseAlt{} = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c
-exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
-exhaustiveWarningFlag ThPatSplice = Nothing
-exhaustiveWarningFlag PatSyn = Nothing
-exhaustiveWarningFlag ThPatQuote = Nothing
+exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag ThPatSplice = Nothing
+exhaustiveWarningFlag PatSyn = Nothing
+exhaustiveWarningFlag ThPatQuote = Nothing
-- Don't warn about incomplete patterns in list comprehensions, pattern guards
-- etc. They are often *supposed* to be incomplete
-exhaustiveWarningFlag (StmtCtxt {}) = Nothing
+exhaustiveWarningFlag StmtCtxt{} = Nothing
arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag = \ case
- ProcExpr -> Just Opt_WarnIncompleteUniPatterns
- ArrowCaseAlt -> Just Opt_WarnIncompletePatterns
- KappaExpr -> Just Opt_WarnIncompleteUniPatterns
+ ProcExpr -> Just Opt_WarnIncompleteUniPatterns
+ ArrowCaseAlt -> Just Opt_WarnIncompletePatterns
+ ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns
+ KappaExpr -> Just Opt_WarnIncompleteUniPatterns
-- | Check whether any part of pattern match checking is enabled for this
-- 'HsMatchContext' (does not matter whether it is the redundancy check or the
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index dfa634b399..ce986f7436 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1499,10 +1499,14 @@ repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)
-repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
+repE (HsLamCase _ LamCase (MG { mg_alts = (L _ ms) }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreListM matchTyConName ms'
; repLamCase core_ms }
+repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) }))
+ = do { ms' <- mapM repClauseTup ms
+ ; core_ms <- coreListM matchTyConName ms'
+ ; repLamCases core_ms }
repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (HsAppType _ e t) = do { a <- repLE e
; s <- repLTy (hswc_body t)
@@ -2359,6 +2363,9 @@ repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+repLamCases :: Core [(M TH.Clause)] -> MetaM (Core (M TH.Exp))
+repLamCases (MkC ms) = rep2 lamCasesEName [ms]
+
repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
repTup (MkC es) = rep2 tupEName [es]
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 17b2b42917..effc1c9688 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -1,4 +1,3 @@
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 19f198e2c3..d3b7978856 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1094,7 +1094,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
HsLam _ mg ->
[ toHie mg
]
- HsLamCase _ mg ->
+ HsLamCase _ _ mg ->
[ toHie mg
]
HsApp _ a b ->
@@ -1415,7 +1415,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
[ toHie expr
, toHie alts
]
- HsCmdLamCase _ alts ->
+ HsCmdLamCase _ _ alts ->
[ toHie alts
]
HsCmdIf _ _ a b c ->
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 55052f0df6..381af647ba 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -648,6 +648,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
'=' { L _ ITequal }
'\\' { L _ ITlam }
'lcase' { L _ ITlcase }
+ 'lcases' { L _ ITlcases }
'|' { L _ ITvbar }
'<-' { L _ (ITlarrow _) }
'->' { L _ (ITrarrow _) }
@@ -2808,9 +2809,12 @@ aexp :: { ECP }
| 'let' binds 'in' exp { ECP $
unECP $4 >>= \ $4 ->
mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }
- | '\\' 'lcase' altslist
+ | '\\' 'lcase' altslist(pats1)
{ ECP $ $3 >>= \ $3 ->
- mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] }
+ mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }
+ | '\\' 'lcases' altslist(apats)
+ { ECP $ $3 >>= \ $3 ->
+ mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
@@ -2828,11 +2832,11 @@ aexp :: { ECP }
fmap ecpFromExp $
acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)
(reverse $ snd $ unLoc $2)) }
- | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
- return $ ECP $
- $4 >>= \ $4 ->
- mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4
- (EpAnnHsCase (glAA $1) (glAA $3) []) }
+ | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
+ return $ ECP $
+ $4 >>= \ $4 ->
+ mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4
+ (EpAnnHsCase (glAA $1) (glAA $3) []) }
-- QualifiedDo.
| DO stmtlist {% do
hintQualifiedDo $1
@@ -3212,48 +3216,48 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-----------------------------------------------------------------------------
-- Case alternatives
-altslist :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }
- : '{' alts '}' { $2 >>= \ $2 -> amsrl
- (sLL $1 $> (reverse (snd $ unLoc $2)))
- (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }
- | vocurly alts close { $2 >>= \ $2 -> amsrl
- (L (getLoc $2) (reverse (snd $ unLoc $2)))
- (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }
- | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }
- | vocurly close { return $ noLocA [] }
-
-alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }
- : alts1 { $1 >>= \ $1 -> return $
+altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }
+ : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsrl
+ (sLL $1 $> (reverse (snd $ unLoc $2)))
+ (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }
+ | vocurly alts(PATS) close { $2 >>= \ $2 -> amsrl
+ (L (getLoc $2) (reverse (snd $ unLoc $2)))
+ (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }
+ | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }
+ | vocurly close { return $ noLocA [] }
+
+alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }
+ : alts1(PATS) { $1 >>= \ $1 -> return $
sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
- | ';' alts { $2 >>= \ $2 -> return $
+ | ';' alts(PATS) { $2 >>= \ $2 -> return $
sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) )
,snd $ unLoc $2) }
-alts1 :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }
- : alts1 ';' alt { $1 >>= \ $1 ->
- $3 >>= \ $3 ->
- case snd $ unLoc $1 of
- [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2)
- ,[$3]))
- (h:t) -> do
- h' <- addTrailingSemiA h (gl $2)
- return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }
- | alts1 ';' { $1 >>= \ $1 ->
- case snd $ unLoc $1 of
- [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
- ,[]))
- (h:t) -> do
- h' <- addTrailingSemiA h (gl $2)
- return (sLL $1 $> (fst $ unLoc $1, h' : t)) }
- | alt { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }
-
-alt :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
- : pat alt_rhs { $2 >>= \ $2 ->
- acsA (\cs -> sLL (reLoc $1) $>
- (Match { m_ext = (EpAnn (glAR $1) [] cs)
- , m_ctxt = CaseAlt
- , m_pats = [$1]
- , m_grhss = unLoc $2 }))}
+alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }
+ : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 ->
+ $3 >>= \ $3 ->
+ case snd $ unLoc $1 of
+ [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2)
+ ,[$3]))
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }
+ | alts1(PATS) ';' { $1 >>= \ $1 ->
+ case snd $ unLoc $1 of
+ [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
+ ,[]))
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLL $1 $> (fst $ unLoc $1, h' : t)) }
+ | alt(PATS) { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }
+
+alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
+ : PATS alt_rhs { $2 >>= \ $2 ->
+ acsA (\cs -> sLLAsl $1 $>
+ (Match { m_ext = EpAnn (listAsAnchor $1) [] cs
+ , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing
+ , m_pats = $1
+ , m_grhss = unLoc $2 }))}
alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
: ralt wherebinds { $1 >>= \alt ->
@@ -3293,6 +3297,11 @@ gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }
pat :: { LPat GhcPs }
pat : exp {% (checkPattern <=< runPV) (unECP $1) }
+-- 'pats1' does the same thing as 'pat', but returns it as a singleton
+-- list so that it can be used with a parameterized production rule
+pats1 :: { [LPat GhcPs] }
+pats1 : pat { [ $1 ] }
+
bindpat :: { LPat GhcPs }
bindpat : exp {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess
checkPattern_details incompleteDoBlock
@@ -4061,6 +4070,11 @@ sLLlA x y = sL (comb2A x y) -- #define LL sL (comb2 $1 $>)
sLLAl :: LocatedAn t a -> Located b -> c -> Located c
sLLAl x y = sL (comb2A y x) -- #define LL sL (comb2 $1 $>)
+{-# INLINE sLLAsl #-}
+sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c
+sLLAsl [] = sL1
+sLLAsl (x:_) = sLLAl x
+
{-# INLINE sLLAA #-}
sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c
sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL sL (comb2 $1 $>)
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index b5effa0797..d3119fb920 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -207,6 +207,7 @@ data AnnKeywordId
| AnnBackquote -- ^ '`'
| AnnBy
| AnnCase -- ^ case or lambda case
+ | AnnCases -- ^ lambda cases
| AnnClass
| AnnClose -- ^ '\#)' or '\#-}' etc
| AnnCloseB -- ^ '|)'
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 4f649d9190..e69aabc0db 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -24,7 +24,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Data.Maybe (catMaybes)
-import GHC.Hs.Expr (prependQualified,HsExpr(..))
+import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)
import GHC.Hs.Type (pprLHsContext)
import GHC.Builtin.Names (allNameStrings)
import GHC.Builtin.Types (filterCTuple)
@@ -175,9 +175,11 @@ instance Diagnostic PsMessage where
, text "Character literals may not be empty"
]
PsErrLambdaCase
- -> mkSimpleDecorated $ text "Illegal lambda-case"
+ -- we can't get this error for \cases, since without -XLambdaCase, that's
+ -- just a regular lambda expression
+ -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword LamCase
PsErrEmptyLambda
- -> mkSimpleDecorated $ text "A lambda requires at least one parameter"
+ -> mkSimpleDecorated $ text "A lambda requires at least one parameter"
PsErrLinearFunction
-> mkSimpleDecorated $ text "Illegal use of linear functions"
PsErrOverloadedRecordUpdateNotEnabled
@@ -312,8 +314,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ text "do-notation in pattern"
PsErrIfThenElseInPat
-> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"
- PsErrLambdaCaseInPat
- -> mkSimpleDecorated $ text "(\\case ...)-syntax in pattern"
+ (PsErrLambdaCaseInPat lc_variant)
+ -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern"
PsErrCaseInPat
-> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"
PsErrLetInPat
@@ -341,6 +343,9 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a
PsErrCaseCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a
+ PsErrLambdaCaseCmdInFunAppCmd lc_variant a
+ -> mkSimpleDecorated $
+ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a
PsErrIfCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a
PsErrLetCmdInFunAppCmd a
@@ -355,8 +360,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a
PsErrCaseInFunAppExpr a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a
- PsErrLambdaCaseInFunAppExpr a
- -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda-case expression") a
+ PsErrLambdaCaseInFunAppExpr lc_variant a
+ -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a
PsErrLetInFunAppExpr a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a
PsErrIfInFunAppExpr a
@@ -556,7 +561,7 @@ instance Diagnostic PsMessage where
PsErrIllegalUnboxedFloatingLitInPat{} -> ErrorWithoutFlag
PsErrDoNotationInPat{} -> ErrorWithoutFlag
PsErrIfThenElseInPat -> ErrorWithoutFlag
- PsErrLambdaCaseInPat -> ErrorWithoutFlag
+ PsErrLambdaCaseInPat{} -> ErrorWithoutFlag
PsErrCaseInPat -> ErrorWithoutFlag
PsErrLetInPat -> ErrorWithoutFlag
PsErrLambdaInPat -> ErrorWithoutFlag
@@ -566,6 +571,7 @@ instance Diagnostic PsMessage where
PsErrViewPatInExpr{} -> ErrorWithoutFlag
PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag
+ PsErrLambdaCaseCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag
@@ -685,7 +691,7 @@ instance Diagnostic PsMessage where
PsErrIllegalUnboxedFloatingLitInPat{} -> noHints
PsErrDoNotationInPat{} -> noHints
PsErrIfThenElseInPat -> noHints
- PsErrLambdaCaseInPat -> noHints
+ PsErrLambdaCaseInPat{} -> noHints
PsErrCaseInPat -> noHints
PsErrLetInPat -> noHints
PsErrLambdaInPat -> noHints
@@ -695,6 +701,7 @@ instance Diagnostic PsMessage where
PsErrViewPatInExpr{} -> noHints
PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs
+ PsErrLambdaCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index d99f789154..f9a1b4661d 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -245,7 +245,7 @@ data PsMessage
| PsErrIfThenElseInPat
-- | Lambda-case in pattern
- | PsErrLambdaCaseInPat
+ | PsErrLambdaCaseInPat LamCaseVariant
-- | case..of in pattern
| PsErrCaseInPat
@@ -311,6 +311,9 @@ data PsMessage
-- | Unexpected case command in function application
| PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- | Unexpected \case(s) command in function application
+ | PsErrLambdaCaseCmdInFunAppCmd !LamCaseVariant !(LHsCmd GhcPs)
+
-- | Unexpected if command in function application
| PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)
@@ -332,8 +335,8 @@ data PsMessage
-- | Unexpected case expression in function application
| PsErrCaseInFunAppExpr !(LHsExpr GhcPs)
- -- | Unexpected lambda-case expression in function application
- | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)
+ -- | Unexpected \case(s) expression in function application
+ | PsErrLambdaCaseInFunAppExpr !LamCaseVariant !(LHsExpr GhcPs)
-- | Unexpected let expression in function application
| PsErrLetInFunAppExpr !(LHsExpr GhcPs)
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index b1d8f43350..82a5b9bb38 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -793,6 +793,7 @@ data Token
| ITequal
| ITlam
| ITlcase
+ | ITlcases
| ITvbar
| ITlarrow IsUnicodeSyntax
| ITrarrow IsUnicodeSyntax
@@ -961,6 +962,7 @@ reservedWordsFM = listToUFM $
[( "_", ITunderscore, 0 ),
( "as", ITas, 0 ),
( "case", ITcase, 0 ),
+ ( "cases", ITlcases, xbit LambdaCaseBit ),
( "class", ITclass, 0 ),
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
@@ -1621,6 +1623,14 @@ varid span buf len =
_ -> return ITcase
maybe_layout keyword
return $ L span keyword
+ Just (ITlcases, _) -> do
+ lastTk <- getLastTk
+ lambdaCase <- getBit LambdaCaseBit
+ token <- case lastTk of
+ Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases
+ _ -> return $ ITvarid fs
+ maybe_layout token
+ return $ L span token
Just (keyword, 0) -> do
maybe_layout keyword
return $ L span keyword
@@ -1862,6 +1872,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
f (ITmdo _) = pushLexState layout_do
f ITof = pushLexState layout
f ITlcase = pushLexState layout
+ f ITlcases = pushLexState layout
f ITlet = pushLexState layout
f ITwhere = pushLexState layout
f ITrec = pushLexState layout
@@ -3169,6 +3180,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf)
+ ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf)
ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo)
ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo)
ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 568f5df5e6..81082534e9 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1026,24 +1026,25 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
where
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = case unLoc expr of
- HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
- HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
- HsLam {} -> check PsErrLambdaInFunAppExpr expr
- HsCase {} -> check PsErrCaseInFunAppExpr expr
- HsLamCase {} -> check PsErrLambdaCaseInFunAppExpr expr
- HsLet {} -> check PsErrLetInFunAppExpr expr
- HsIf {} -> check PsErrIfInFunAppExpr expr
- HsProc {} -> check PsErrProcInFunAppExpr expr
- _ -> return ()
+ HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
+ HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
+ HsLam {} -> check PsErrLambdaInFunAppExpr expr
+ HsCase {} -> check PsErrCaseInFunAppExpr expr
+ HsLamCase _ lc_variant _ -> check (PsErrLambdaCaseInFunAppExpr lc_variant) expr
+ HsLet {} -> check PsErrLetInFunAppExpr expr
+ HsIf {} -> check PsErrIfInFunAppExpr expr
+ HsProc {} -> check PsErrProcInFunAppExpr expr
+ _ -> return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
- HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd
- HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
- HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
- HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
- HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
- _ -> return ()
+ HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd
+ HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
+ HsCmdLamCase _ lc_variant _ -> check (PsErrLambdaCaseCmdInFunAppCmd lc_variant) cmd
+ HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
+ HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
+ HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
+ _ -> return ()
check err a = do
blockArguments <- getBit BlockArgumentsBit
@@ -1489,8 +1490,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate "case ... of ..."
mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])
-> EpAnnHsCase -> PV (LocatedA b)
- mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)])
- -> [AddEpAnn]
+ -- | Disambiguate "\case" and "\cases"
+ mkHsLamCasePV :: SrcSpan -> LamCaseVariant
+ -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]
-> PV (LocatedA b)
-- | Function argument representation
type FunArg b
@@ -1630,10 +1632,10 @@ instance DisambECP (HsCmd GhcPs) where
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)
- mkHsLamCasePV l (L lm m) anns = do
+ mkHsLamCasePV l lc_variant (L lm m) anns = do
cs <- getCommentsFor l
- let mg = mkMatchGroup FromSource (L lm m)
- return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) mg)
+ let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)
+ return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)
type FunArg (HsCmd GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l c e = do
@@ -1716,10 +1718,10 @@ instance DisambECP (HsExpr GhcPs) where
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)
- mkHsLamCasePV l (L lm m) anns = do
+ mkHsLamCasePV l lc_variant (L lm m) anns = do
cs <- getCommentsFor l
- let mg = mkMatchGroup FromSource (L lm m)
- return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) mg)
+ let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)
+ return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)
type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l e1 e2 = do
@@ -1804,8 +1806,8 @@ instance DisambECP (PatBuilder GhcPs) where
cs <- getCommentsFor l
let anns = EpAnn (spanAsAnchor l) [] cs
return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns
- mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
- mkHsLamCasePV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat
+ mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
+ mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant)
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index adfceeef96..0239bf759b 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1189,15 +1189,43 @@ type AnnoBody body
, Outputable (body GhcPs)
)
+-- Note [Empty MatchGroups]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+-- In some cases, MatchGroups are allowed to be empty. Firstly, the
+-- prerequisite is that -XEmptyCase is enabled. Then you have an empty
+-- MatchGroup resulting either from a case-expression:
+--
+-- case e of {}
+--
+-- or from a \case-expression:
+--
+-- \case {}
+--
+-- NB: \cases {} is not allowed, since it's not clear how many patterns this
+-- should match on.
+--
+-- The same applies in arrow notation commands: With -XEmptyCases, it is
+-- allowed in case- and \case-commands, but not \cases.
+--
+-- Since the lambda expressions and empty function definitions are already
+-- disallowed elsewhere, here, we only need to make sure we don't accept empty
+-- \cases expressions or commands. In that case, or if we encounter an empty
+-- MatchGroup but -XEmptyCases is disabled, we add an error.
+
rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })
- = do { empty_case_ok <- xoptM LangExt.EmptyCase
- ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
+ -- see Note [Empty MatchGroups]
+ = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }
+ where
+ mustn't_be_empty = case ctxt of
+ LamCaseAlt LamCases -> return True
+ ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> return True
+ _ -> not <$> xoptM LangExt.EmptyCase
rnMatch :: AnnoBody body
=> HsMatchContext GhcRn
@@ -1222,17 +1250,28 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
, m_grhss = grhss'}, grhss_fvs ) }
emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage
-emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $
- hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)
- 2 (text "Use EmptyCase to allow this")
+emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ message ctxt
where
pp_ctxt :: HsMatchContext GhcRn -> SDoc
pp_ctxt c = case c of
- CaseAlt -> text "case expression"
- LambdaExpr -> text "\\case expression"
- ArrowMatchCtxt ArrowCaseAlt -> text "case expression"
- ArrowMatchCtxt KappaExpr -> text "kappa abstraction"
- _ -> text "(unexpected)" <+> pprMatchContextNoun c
+ CaseAlt -> text "case expression"
+ LamCaseAlt LamCase -> text "\\case expression"
+ ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"
+ ArrowMatchCtxt ArrowCaseAlt -> text "case command"
+ ArrowMatchCtxt KappaExpr -> text "kappa abstraction"
+ _ -> text "(unexpected)"
+ <+> pprMatchContextNoun c
+
+ message :: HsMatchContext GhcRn -> SDoc
+ message (LamCaseAlt LamCases) = lcases_msg <+> text "expression"
+ message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) =
+ lcases_msg <+> text "command"
+ message ctxt =
+ hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)
+ 2 (text "Use EmptyCase to allow this")
+
+ lcases_msg =
+ text "Empty list of alternatives is not allowed in \\cases"
{-
************************************************************************
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index d8b2436dc1..ac0de6b772 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -374,9 +374,9 @@ rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
; return (HsLam x matches', fvMatch) }
-rnExpr (HsLamCase x matches)
- = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
- ; return (HsLamCase x matches', fvs_ms) }
+rnExpr (HsLamCase x lc_variant matches)
+ = do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches
+ ; return (HsLamCase x lc_variant matches', fvs_ms) }
rnExpr (HsCase _ expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
@@ -810,9 +810,10 @@ rnCmd (HsCmdCase _ expr matches)
; return (HsCmdCase noExtField new_expr new_matches
, e_fvs `plusFV` ms_fvs) }
-rnCmd (HsCmdLamCase x matches)
- = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
- ; return (HsCmdLamCase x new_matches, ms_fvs) }
+rnCmd (HsCmdLamCase x lc_variant matches)
+ = do { (new_matches, ms_fvs) <-
+ rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches
+ ; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) }
rnCmd (HsCmdIf _ _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
@@ -864,7 +865,7 @@ methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match
methodNamesCmd (HsCmdCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
-methodNamesCmd (HsCmdLamCase _ matches)
+methodNamesCmd (HsCmdLamCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
--methodNamesCmd _ = emptyFVs
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index cab71a1deb..95afe9c982 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -257,10 +257,6 @@ instance Diagnostic TcRnMessage where
TcRnArrowIfThenElsePredDependsOnResultTy
-> mkSimpleDecorated $
text "Predicate type of `ifThenElse' depends on result type"
- TcRnArrowCommandExpected cmd
- -> mkSimpleDecorated $
- vcat [text "The expression", nest 2 (ppr cmd),
- text "was found where an arrow command was expected"]
TcRnIllegalHsBootFileDecl
-> mkSimpleDecorated $
text "Illegal declarations in an hs-boot file"
@@ -876,8 +872,6 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnArrowIfThenElsePredDependsOnResultTy
-> ErrorWithoutFlag
- TcRnArrowCommandExpected{}
- -> ErrorWithoutFlag
TcRnIllegalHsBootFileDecl
-> ErrorWithoutFlag
TcRnRecursivePatternSynonym{}
@@ -1138,8 +1132,6 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnArrowIfThenElsePredDependsOnResultTy
-> noHints
- TcRnArrowCommandExpected{}
- -> noHints
TcRnIllegalHsBootFileDecl
-> noHints
TcRnRecursivePatternSynonym{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 9a9a64130f..113e89c15b 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -620,15 +620,6 @@ data TcRnMessage where
-}
TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage
- {-| TcRnArrowCommandExpected is an error that occurs if a non-arrow command
- is used where an arrow command is expected.
-
- Example(s): None
-
- Test cases: None
- -}
- TcRnArrowCommandExpected :: HsCmd GhcRn -> TcRnMessage
-
{-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file
contains declarations that are not allowed, such as bindings.
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index ad4b67ee88..d3035b5cf2 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -45,6 +46,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
+import qualified GHC.Data.Strict as Strict
+
import Control.Monad
{-
@@ -164,19 +167,21 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $ do
(scrut', scrut_ty) <- tcInferRho scrut
hasFixedRuntimeRep_MustBeRefl
- (FRRArrow $ ArrowCmdCase { isCmdLamCase = False })
+ (FRRArrow $ ArrowCmdCase)
scrut_ty
matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
return (HsCmdCase x scrut' matches')
-tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty)
- = addErrCtxt (cmdCtxt in_cmd) $ do
- (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk
- hasFixedRuntimeRep_MustBeRefl
- (FRRArrow $ ArrowCmdCase { isCmdLamCase = True })
- scrut_ty
- matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty)
- return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches'))
+tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty
+ = addErrCtxt (cmdCtxt cmd)
+ do { let match_ctxt = ArrowLamCaseAlt lc_variant
+ ; checkPatCounts (ArrowMatchCtxt match_ctxt) match
+ ; (wrap, match') <-
+ tcCmdMatchLambda env match_ctxt mk_origin match cmd_ty
+ ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }
+ where mk_origin = ArrowCmdLamCase . case lc_variant of
+ LamCase -> const Strict.Nothing
+ LamCases -> Strict.Just
tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if'
= do { pred' <- tcCheckMonoExpr pred boolTy
@@ -269,52 +274,9 @@ tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
-- ------------------------------
-- D;G |-a (\x.cmd) : (t,stk) --> res
-tc_cmd env
- (HsCmdLam x (MG { mg_alts = L l [L mtch_loc
- (match@(Match { m_pats = pats, m_grhss = grhss }))],
- mg_origin = origin }))
- (cmd_stk, res_ty)
- = addErrCtxt (pprMatchInCtxt match) $
- do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
-
- -- Check the patterns, and the GRHSs inside
- ; (pats', grhss') <- setSrcSpanA mtch_loc $
- tcPats (ArrowMatchCtxt KappaExpr)
- pats (map (unrestricted . mkCheckExpType) arg_tys) $
- tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
-
- ; let match' = L mtch_loc (Match { m_ext = noAnn
- , m_ctxt = ArrowMatchCtxt KappaExpr
- , m_pats = pats'
- , m_grhss = grhss' })
- arg_tys = map (unrestricted . hsLPatType) pats'
-
- ; zipWithM_
- (\ (Scaled _ arg_ty) i ->
- hasFixedRuntimeRep_MustBeRefl (FRRArrow $ ArrowCmdLam i) arg_ty)
- arg_tys
- [1..]
-
- ; let
- cmd' = HsCmdLam x (MG { mg_alts = L l [match']
- , mg_ext = MatchGroupTc arg_tys res_ty
- , mg_origin = origin })
- ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
- where
- n_pats = length pats
- match_ctxt = ArrowMatchCtxt KappaExpr
- pg_ctxt = PatGuard match_ctxt
-
- tc_grhss (GRHSs x grhss binds) stk_ty res_ty
- = do { (binds', grhss') <- tcLocalBinds binds $
- mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss
- ; return (GRHSs x grhss' binds') }
-
- tc_grhs stk_ty res_ty (GRHS x guards body)
- = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
- \ res_ty -> tcCmd env body
- (stk_ty, checkingExpType "tc_grhs" res_ty)
- ; return (GRHS x guards' rhs') }
+tc_cmd env (HsCmdLam x match) cmd_ty
+ = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr ArrowCmdLam match cmd_ty
+ ; return (mkHsCmdWrap wrap (HsCmdLam x match')) }
-------------------------------------------
-- Do notation
@@ -340,7 +302,7 @@ tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
-- D; G |-a (| e c1 ... cn |) : stk --> t
tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
- = addErrCtxt (cmdCtxt cmd) $
+ = addErrCtxt (cmdCtxt cmd)
do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
-- We use alphaTyVar for 'w'
; let e_ty = mkInfForAllTy alphaTyVar $
@@ -361,15 +323,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
------------------------------------------------------------------
--- Base case for illegal commands
--- This is where expressions that aren't commands get rejected
-
-tc_cmd _ cmd _
- = failWithTc (TcRnArrowCommandExpected cmd)
-
--- | Typechecking for case command alternatives. Used for both
--- 'HsCmdCase' and 'HsCmdLamCase'.
+-- | Typechecking for case command alternatives. Used for 'HsCmdCase'.
tcCmdMatches :: CmdEnv
-> TcType -- ^ Type of the scrutinee.
-- Must have a fixed RuntimeRep as per
@@ -385,6 +339,68 @@ tcCmdMatches env scrut_ty matches (stk, res_ty)
mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
; tcCmd env body (stk, res_ty') }
+-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
+tcCmdMatchLambda :: CmdEnv
+ -> HsArrowMatchContext
+ -> (Int -> FRRArrowOrigin) -- ^ Function that creates an origin
+ -- given the index of a pattern
+ -> MatchGroup GhcRn (LHsCmd GhcRn)
+ -> CmdType
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
+tcCmdMatchLambda env
+ ctxt
+ mk_origin
+ mg@MG { mg_alts = L l matches }
+ (cmd_stk, res_ty)
+ = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
+
+ ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys
+ ; matches' <- forM matches $
+ addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'
+
+ ; let arg_tys' = map unrestricted arg_tys
+ mg' = mg { mg_alts = L l matches'
+ , mg_ext = MatchGroupTc arg_tys' res_ty }
+
+ ; return (mkWpCastN co, mg') }
+ where
+ n_pats | isEmptyMatchGroup mg = 1 -- must be lambda-case
+ | otherwise = matchGroupArity mg
+
+ -- Check the patterns, and the GRHSs inside
+ tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))
+ = do { (pats', grhss') <- setSrcSpanA mtch_loc $
+ tcPats match_ctxt pats arg_tys $
+ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
+
+ ; let arg_tys' = map (unrestricted . hsLPatType) pats'
+
+ ; zipWithM_
+ (\ (Scaled _ arg_ty) i ->
+ hasFixedRuntimeRep_MustBeRefl (FRRArrow $ mk_origin i) arg_ty)
+ arg_tys'
+ [1..]
+
+ ; return $ L mtch_loc (Match { m_ext = noAnn
+ , m_ctxt = match_ctxt
+ , m_pats = pats'
+ , m_grhss = grhss' }) }
+
+
+ match_ctxt = ArrowMatchCtxt ctxt
+ pg_ctxt = PatGuard match_ctxt
+
+ tc_grhss (GRHSs x grhss binds) stk_ty res_ty
+ = do { (binds', grhss') <- tcLocalBinds binds $
+ mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss
+ ; return (GRHSs x grhss' binds') }
+
+ tc_grhs stk_ty res_ty (GRHS x guards body)
+ = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
+ \ res_ty -> tcCmd env body
+ (stk_ty, checkingExpType "tc_grhs" res_ty)
+ ; return (GRHS x guards' rhs') }
+
matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
matchExpectedCmdArgs 0 ty
= return (mkTcNomReflCo ty, [], ty)
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 5cfe527c70..b5e9982f48 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -264,13 +264,13 @@ tcExpr (HsLam _ match) res_ty
match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
herald = ExpectedFunTyLam match
-tcExpr e@(HsLamCase x matches) res_ty
+tcExpr e@(HsLamCase x lc_variant matches) res_ty
= do { (wrap, matches')
<- tcMatchLambda herald match_ctxt matches res_ty
- ; return (mkHsWrap wrap $ HsLamCase x matches') }
+ ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') }
where
- match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
- herald = ExpectedFunTyLamCase e
+ match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody }
+ herald = ExpectedFunTyLamCase lc_variant e
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index d6f3590910..0763ad2679 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -31,6 +31,7 @@ module GHC.Tc.Gen.Match
, tcBody
, tcDoStmt
, tcGuardStmt
+ , checkPatCounts
)
where
@@ -105,7 +106,9 @@ tcMatchesFun fun_id matches exp_ty
-- ann-grabbing, because we don't always have annotations in
-- hand when we call tcMatchesFun...
traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
- ; checkArgs fun_name matches
+ -- We can't easily call checkPatCounts here because fun_id can be an
+ -- unfilled thunk
+ ; checkArgCounts fun_name matches
; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
-- NB: exp_type may be polymorphic, but
@@ -161,8 +164,10 @@ tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda herald match_ctxt match res_ty
- = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
- tcMatches match_ctxt pat_tys rhs_ty match
+ = do { checkPatCounts (mc_what match_ctxt) match
+ ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do
+ -- checking argument counts since this is also used for \cases
+ tcMatches match_ctxt pat_tys rhs_ty match }
where
n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case
| otherwise = matchGroupArity match
@@ -1132,23 +1137,35 @@ the variables they bind into scope, and typecheck the thing_inside.
* *
************************************************************************
-@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
+@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
number of args are used in each equation.
-}
-checkArgs :: AnnoBody body
- => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
-checkArgs _ (MG { mg_alts = L _ [] })
+checkArgCounts :: AnnoBody body
+ => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
+checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr
+
+-- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same
+-- number of patterns are used in each alternative
+checkPatCounts :: AnnoBody body
+ => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
+ -> TcM ()
+checkPatCounts = check_match_pats . pprMatchContextNouns
+
+check_match_pats :: AnnoBody body
+ => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn))
+ -> TcM ()
+check_match_pats _ (MG { mg_alts = L _ [] })
= return ()
-checkArgs fun (MG { mg_alts = L _ (match1:matches) })
+check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) })
| null bad_matches
= return ()
| otherwise
= failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
- (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
- text "have different numbers of arguments"
- , nest 2 (ppr (getLocA match1))
- , nest 2 (ppr (getLocA (head bad_matches)))])
+ (vcat [ err_msg <+>
+ text "have different numbers of arguments"
+ , nest 2 (ppr (getLocA match1))
+ , nest 2 (ppr (getLocA (head bad_matches)))])
where
n_args1 = args_in_match match1
bad_matches = [m | m <- matches, args_in_match m /= n_args1]
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 55730e20d1..82dbafcdf1 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -60,6 +60,7 @@ import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -684,7 +685,7 @@ exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit
exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms
+exprCtOrigin (HsLamCase _ _ ms) = matchesCtOrigin ms
exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1
exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
@@ -1169,14 +1170,19 @@ data FRRArrowOrigin
-- Test cases: none.
| ArrowCmdLam !Int
- -- | The scrutinee type in an arrow command case or lambda-case
- -- statement does not have a fixed runtime representation.
+ -- | The scrutinee type in an arrow command case statement does not have a
+ -- fixed runtime representation.
--
-- Test cases: none.
- | ArrowCmdCase { isCmdLamCase :: Bool
- -- ^ Whether this is a lambda-case (True)
- -- or a normal case (False)
- }
+ | ArrowCmdCase
+
+ -- | A pattern in an arrow command \cases statement does not
+ -- have a fixed runtime representation.
+ --
+ -- Test cases: none.
+ | ArrowCmdLamCase !(Strict.Maybe Int)
+ -- ^ @Nothing@ for @\case@, @Just@ the index of the pattern for @\cases@
+ -- (starting from 1)
-- | The overall type of an arrow proc expression does not have
-- a fixed runtime representation.
@@ -1199,13 +1205,13 @@ pprFRRArrowOrigin (ArrowCmdArrApp fun arg ho_app)
, nest 2 (quotes (ppr arg)) ]
pprFRRArrowOrigin (ArrowCmdLam i)
= vcat [ text "The" <+> speakNth i <+> text "pattern of the arrow command abstraction" ]
-pprFRRArrowOrigin (ArrowCmdCase { isCmdLamCase = is_lam_case })
- = text "The scrutinee of the arrow" <+> what <+> text "command"
- where
- what :: SDoc
- what = if is_lam_case
- then text "lambda-case"
- else text "case"
+pprFRRArrowOrigin ArrowCmdCase
+ = text "The scrutinee of the arrow case command"
+pprFRRArrowOrigin (ArrowCmdLamCase Strict.Nothing)
+ = text "The scrutinee of the arrow \\case command"
+pprFRRArrowOrigin (ArrowCmdLamCase (Strict.Just i))
+ = text "The" <+> speakNth i
+ <+> text "scrutinee of the arrow \\cases command"
pprFRRArrowOrigin (ArrowFun fun)
= vcat [ text "The return type of the arrow function"
, nest 2 (quotes (ppr fun)) ]
@@ -1246,7 +1252,7 @@ data ExpectedFunTyOrigin
-- ^ argument
| ExpectedFunTyMatches !TypedThing !(MatchGroup GhcRn (LHsExpr GhcRn))
| ExpectedFunTyLam !(MatchGroup GhcRn (LHsExpr GhcRn))
- | ExpectedFunTyLamCase !(HsExpr GhcRn)
+ | ExpectedFunTyLamCase LamCaseVariant !(HsExpr GhcRn)
pprExpectedFunTyOrigin :: ExpectedFunTyOrigin
-> Int -- ^ argument position (starting at 1)
@@ -1272,14 +1278,15 @@ pprExpectedFunTyOrigin funTy_origin i =
| otherwise
-> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
<+> text "for" <+> quotes (ppr fun)
- ExpectedFunTyLam {} ->
- text "The binder of the lambda expression"
- ExpectedFunTyLamCase {} ->
- text "The binder of the lambda-case expression"
+ ExpectedFunTyLam {} -> binder_of $ text "lambda"
+ ExpectedFunTyLamCase lc_variant _ -> binder_of $ lamCaseKeyword lc_variant
where
the_arg_of :: SDoc
the_arg_of = text "The" <+> speakNth i <+> text "argument of"
+ binder_of :: SDoc -> SDoc
+ binder_of what = text "The binder of the" <+> what <+> text "expression"
+
pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})
= text "This rebindable syntax expects a function with"
@@ -1296,6 +1303,6 @@ pprExpectedFunTyHerald (ExpectedFunTyLam match)
pprMatches match)
-- The pprSetDepth makes the lambda abstraction print briefly
, text "has" ]
-pprExpectedFunTyHerald (ExpectedFunTyLamCase expr)
+pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)
= sep [ text "The function" <+> quotes (ppr expr)
, text "requires" ]
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index b0af88d813..0747db57e4 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -763,9 +763,9 @@ zonkExpr env (HsLam x matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLam x new_matches)
-zonkExpr env (HsLamCase x matches)
+zonkExpr env (HsLamCase x lc_variant matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
- return (HsLamCase x new_matches)
+ return (HsLamCase x lc_variant new_matches)
zonkExpr env (HsApp x e1 e2)
= do new_e1 <- zonkLExpr env e1
@@ -1004,9 +1004,9 @@ zonkCmd env (HsCmdCase x expr ms)
new_ms <- zonkMatchGroup env zonkLCmd ms
return (HsCmdCase x new_expr new_ms)
-zonkCmd env (HsCmdLamCase x ms)
+zonkCmd env (HsCmdLamCase x lc_variant ms)
= do new_ms <- zonkMatchGroup env zonkLCmd ms
- return (HsCmdLamCase x new_ms)
+ return (HsCmdLamCase x lc_variant new_ms)
zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
= do { (env1, new_eCond) <- zonkSyntaxExpr env eCond
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 7644109ae0..82f30c4757 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -57,7 +57,6 @@ import GHC.Utils.Panic
import qualified Data.ByteString as BS
import Control.Monad( unless, ap )
-
import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
@@ -1012,16 +1011,21 @@ cvtl e = wrapLA (cvt e)
; th_origin <- getOrigin
; wrapParLA (HsLam noExtField . mkMatchGroup th_origin)
[mkSimpleMatch LambdaExpr pats e']}
- cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms
+ cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch $ LamCaseAlt LamCase) ms
; th_origin <- getOrigin
- ; wrapParLA (HsLamCase noAnn . mkMatchGroup th_origin) ms'
+ ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms'
}
+ cvt (LamCasesE ms)
+ | null ms = failWith (text "\\cases expression with no alternatives")
+ | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms
+ ; th_origin <- getOrigin
+ ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms'
+ }
cvt (TupE es) = cvt_tup es Boxed
cvt (UnboxedTupE es) = cvt_tup es Unboxed
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
- ; return $ ExplicitSum noAnn
- alt arity e'}
+ ; return $ ExplicitSum noAnn alt arity e'}
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ mkHsIf x' y' z' noAnn }
cvt (MultiIfE alts)
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 67fa0fb796..69cb0b6dd0 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -360,13 +360,17 @@ data HsExpr p
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
- --
- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
- -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',
- -- 'GHC.Parser.Annotation.AnnClose'
+ -- | Lambda-case
+ --
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
+ -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',
+ -- 'GHC.Parser.Annotation.AnnClose'
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
+ -- 'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen',
+ -- 'GHC.Parser.Annotation.AnnClose'
- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+ | HsLamCase (XLamCase p) LamCaseVariant (MatchGroup p (LHsExpr p))
| HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
@@ -679,6 +683,16 @@ data HsTupArg id
| XTupArg !(XXTupArg id) -- ^ Extension point; see Note [Trees That Grow]
-- in Language.Haskell.Syntax.Extension
+-- | Which kind of lambda case are we dealing with?
+data LamCaseVariant
+ = LamCase -- ^ `\case`
+ | LamCases -- ^ `\cases`
+ deriving (Data, Eq)
+
+lamCaseKeyword :: LamCaseVariant -> SDoc
+lamCaseKeyword LamCase = text "\\case"
+lamCaseKeyword LamCases = text "\\cases"
+
{-
Note [Parens in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~
@@ -913,13 +927,18 @@ data HsCmd id
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- | HsCmdLamCase (XCmdLamCase id)
- (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
- -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
- -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,
- -- 'GHC.Parser.Annotation.AnnClose' @'}'@
+ -- | Lambda-case
+ --
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
+ -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,
+ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
+ -- 'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen' @'{'@,
+ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+ | HsCmdLamCase (XCmdLamCase id) LamCaseVariant
+ (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
| HsCmdIf (XCmdIf id)
(SyntaxExpr id) -- cond function
@@ -1654,7 +1673,8 @@ data HsMatchContext p
-- See Note [FunBind vs PatBind]
}
| LambdaExpr -- ^Patterns of a lambda
- | CaseAlt -- ^Patterns and guards on a case alternative
+ | CaseAlt -- ^Patterns and guards in a case alternative
+ | LamCaseAlt LamCaseVariant -- ^Patterns and guards in @\case@ and @\cases@
| IfAlt -- ^Guards of a multi-way if alternative
| ArrowMatchCtxt -- ^A pattern match inside arrow notation
HsArrowMatchContext
@@ -1690,9 +1710,10 @@ data HsStmtContext p
-- | Haskell arrow match context.
data HsArrowMatchContext
- = ProcExpr -- ^ A proc expression
- | ArrowCaseAlt -- ^ A case alternative inside arrow notation
- | KappaExpr -- ^ An arrow kappa abstraction
+ = ProcExpr -- ^ A proc expression
+ | ArrowCaseAlt -- ^ A case alternative inside arrow notation
+ | ArrowLamCaseAlt LamCaseVariant -- ^ A \case or \cases alternative inside arrow notation
+ | KappaExpr -- ^ An arrow kappa abstraction
data HsDoFlavour
= DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... }
@@ -1752,15 +1773,16 @@ isMonadDoCompContext (DoExpr _) = False
isMonadDoCompContext (MDoExpr _) = False
matchSeparator :: HsMatchContext p -> SDoc
-matchSeparator (FunRhs {}) = text "="
-matchSeparator CaseAlt = text "->"
-matchSeparator IfAlt = text "->"
-matchSeparator LambdaExpr = text "->"
-matchSeparator (ArrowMatchCtxt{})= text "->"
-matchSeparator PatBindRhs = text "="
-matchSeparator PatBindGuards = text "="
-matchSeparator (StmtCtxt _) = text "<-"
-matchSeparator RecUpd = text "=" -- This can be printed by the pattern
+matchSeparator FunRhs{} = text "="
+matchSeparator CaseAlt = text "->"
+matchSeparator LamCaseAlt{} = text "->"
+matchSeparator IfAlt = text "->"
+matchSeparator LambdaExpr = text "->"
+matchSeparator ArrowMatchCtxt{} = text "->"
+matchSeparator PatBindRhs = text "="
+matchSeparator PatBindGuards = text "="
+matchSeparator StmtCtxt{} = text "<-"
+matchSeparator RecUpd = text "=" -- This can be printed by the pattern
-- match checker trace
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
@@ -1779,26 +1801,45 @@ pprMatchContext ctxt
pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
=> HsMatchContext p -> SDoc
-pprMatchContextNoun (FunRhs {mc_fun=fun})
- = text "equation for"
- <+> quotes (ppr (unXRec @p fun))
-pprMatchContextNoun CaseAlt = text "case alternative"
-pprMatchContextNoun IfAlt = text "multi-way if alternative"
-pprMatchContextNoun RecUpd = text "record-update construct"
-pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
-pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
-pprMatchContextNoun PatBindRhs = text "pattern binding"
-pprMatchContextNoun PatBindGuards = text "pattern binding guards"
-pprMatchContextNoun LambdaExpr = text "lambda abstraction"
-pprMatchContextNoun (ArrowMatchCtxt c)= pprArrowMatchContextNoun c
-pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
- $$ pprAStmtContext ctxt
-pprMatchContextNoun PatSyn = text "pattern synonym declaration"
+pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"
+ <+> quotes (ppr (unXRec @p fun))
+pprMatchContextNoun CaseAlt = text "case alternative"
+pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant
+ <+> text "alternative"
+pprMatchContextNoun IfAlt = text "multi-way if alternative"
+pprMatchContextNoun RecUpd = text "record-update construct"
+pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
+pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
+pprMatchContextNoun PatBindRhs = text "pattern binding"
+pprMatchContextNoun PatBindGuards = text "pattern binding guards"
+pprMatchContextNoun LambdaExpr = text "lambda abstraction"
+pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c
+pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
+ $$ pprAStmtContext ctxt
+pprMatchContextNoun PatSyn = text "pattern synonym declaration"
+
+pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)
+ => HsMatchContext p -> SDoc
+pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for"
+ <+> quotes (ppr (unXRec @p fun))
+pprMatchContextNouns PatBindGuards = text "pattern binding guards"
+pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c
+pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in"
+ $$ pprAStmtContext ctxt
+pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's'
pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc
-pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern"
-pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"
-pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction"
+pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern"
+pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"
+pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant
+ <+> text "alternative within arrow notation"
+pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction"
+
+pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc
+pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation"
+pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant
+ <+> text "alternatives within arrow notation"
+pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
-----------------
pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 53031d867c..dc39d10c99 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -519,18 +519,18 @@ type family XXStmtLR x x' b
-- -------------------------------------
-- HsCmd type families
-type family XCmdArrApp x
-type family XCmdArrForm x
-type family XCmdApp x
-type family XCmdLam x
-type family XCmdPar x
-type family XCmdCase x
-type family XCmdLamCase x
-type family XCmdIf x
-type family XCmdLet x
-type family XCmdDo x
-type family XCmdWrap x
-type family XXCmd x
+type family XCmdArrApp x
+type family XCmdArrForm x
+type family XCmdApp x
+type family XCmdLam x
+type family XCmdPar x
+type family XCmdCase x
+type family XCmdLamCase x
+type family XCmdIf x
+type family XCmdLet x
+type family XCmdDo x
+type family XCmdWrap x
+type family XXCmd x
-- -------------------------------------
-- ParStmtBlock type families
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 2576a21cea..91d866d982 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -41,6 +41,12 @@ Language
re-exported from ``Prelude``. When ``(~)`` is not in scope, its use results
in a warning (:ghc-flag:`-Wtype-equality-out-of-scope`).
+- GHC Proposal `#302 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0302-cases.rst>`_ has been implemented.
+ This means under ``-XLambdaCase``, a new expression heralded by ``\cases`` is
+ available, which works like ``\case`` but can match on multiple patterns.
+ This means constructor patterns with arguments have to parenthesized here,
+ just like in lambda expressions.
+
- There were previously cases around functional dependencies and injective
type families where the result of type inference would depend on the order
of constraints, as written in a source file. These cases are fundamentally ambiguous.
diff --git a/docs/users_guide/exts/empty_case.rst b/docs/users_guide/exts/empty_case.rst
index c42de22e9e..7a32f609e6 100644
--- a/docs/users_guide/exts/empty_case.rst
+++ b/docs/users_guide/exts/empty_case.rst
@@ -19,6 +19,9 @@ or ::
\case { } -- -XLambdaCase is also required
+Note that it is not allowed for ``\cases``, since it would be unclear how many
+patterns are being matched.
+
This can be useful when you know that the expression being scrutinised
has no non-bottom values. For example:
@@ -45,5 +48,3 @@ We much prefer (B). Why? Because GHC can figure out that
is able to compile with :ghc-flag:`-Wincomplete-patterns` and
:ghc-flag:`-Werror`. On the other hand (A) looks dangerous, and GHC doesn't
check to make sure that, in fact, the function can never get called.
-
-
diff --git a/docs/users_guide/exts/lambda_case.rst b/docs/users_guide/exts/lambda_case.rst
index 74bc84e164..6872101698 100644
--- a/docs/users_guide/exts/lambda_case.rst
+++ b/docs/users_guide/exts/lambda_case.rst
@@ -18,7 +18,20 @@ which is equivalent to ::
\freshName -> case freshName of { p1 -> e1; ...; pN -> eN }
-Note that ``\case`` starts a layout, so you can write ::
+Since GHC 9.4.1, it also allow expressions with multiple scrutinees (see GHC
+proposal `#302 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0302-cases.rst>`_)
+of the form ::
+
+ \cases { p11 ... pM1 -> e1; ...; p1N ... pMN -> eN }
+
+which is equivalent to a function defined as
+
+ f p11 ... pM1 -> e1
+ ...
+ f p1N ... pMN -> eN
+
+
+Note that both ``\case`` and ``\cases`` start a layout, so you can write ::
\case
p1 -> e1
@@ -26,8 +39,8 @@ Note that ``\case`` starts a layout, so you can write ::
pN -> eN
Additionally, since GHC 9.0.1, combining :extension:`LambdaCase` with
-:extension:`Arrows` allows ``\case`` syntax to be used as a command in
-``proc`` notation: ::
+:extension:`Arrows` allows ``\case`` (and since GHC 9.4.1 ``\cases``)
+syntax to be used as a command in ``proc`` notation: ::
proc x -> (f -< x) `catchA` \case
p1 -> cmd1
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index b6ffd29da1..d4a59b440c 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -364,4 +364,3 @@ resizeSmallMutableArray# arr0 szNew a s0 =
-- accessible\" by word.
considerAccessible :: Bool
considerAccessible = True
-
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 42fa6cd501..8e8e41df2f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -42,9 +42,9 @@ module Language.Haskell.TH.Lib (
-- *** Expressions
dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE,
appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,
- lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,
- letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
- getFieldE, projectionE,
+ lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,
+ multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,
+ fieldExp, getFieldE, projectionE,
-- **** Ranges
fromE, fromThenE, fromToE, fromThenToE,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index e960f35bb3..5d2a32d761 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -300,9 +300,14 @@ lamE ps e = do ps' <- sequenceA ps
lam1E :: Quote m => m Pat -> m Exp -> m Exp
lam1E p e = lamE [p] e
+-- | Lambda-case (@\case@)
lamCaseE :: Quote m => [m Match] -> m Exp
lamCaseE ms = LamCaseE <$> sequenceA ms
+-- | Lambda-cases (@\cases@)
+lamCasesE :: Quote m => [m Clause] -> m Exp
+lamCasesE ms = LamCasesE <$> sequenceA ms
+
tupE :: Quote m => [Maybe (m Exp)] -> m Exp
tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)}
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 51e89fda2a..e2af99339f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -154,8 +154,11 @@ pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
pprExp i (LamE [] e) = pprExp i e -- #13856
pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
<+> text "->" <+> ppr e
-pprExp i (LamCaseE ms) = parensIf (i > noPrec)
- $ text "\\case" $$ braces (semiSep ms)
+pprExp i (LamCaseE ms)
+ = parensIf (i > noPrec) $ text "\\case" $$ braces (semiSep ms)
+pprExp i (LamCasesE ms)
+ = parensIf (i > noPrec) $ text "\\cases" $$ braces (semi_sep ms)
+ where semi_sep = sep . punctuate semi . map (pprClause False)
pprExp i (TupE es)
| [Just e] <- es
= pprExp i (ConE (tupleDataName 1) `AppE` e)
@@ -270,6 +273,12 @@ pprBody eq body = case body of
| otherwise = arrow
------------------------------
+pprClause :: Bool -> Clause -> Doc
+pprClause eqDoc (Clause ps rhs ds)
+ = hsep (map (pprPat appPrec) ps) <+> pprBody eqDoc rhs
+ $$ where_clause ds
+
+------------------------------
instance Ppr Lit where
ppr = pprLit noPrec
@@ -652,8 +661,7 @@ instance Ppr RuleBndr where
------------------------------
instance Ppr Clause where
- ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
- $$ where_clause ds
+ ppr = pprClause True
------------------------------
instance Ppr Con where
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 08d2ea41bf..fdf2e6bf39 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2242,6 +2242,7 @@ type FieldPat = (Name,Pat)
data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
deriving( Show, Eq, Ord, Data, Generic )
+
data Clause = Clause [Pat] Body [Dec]
-- ^ @f { p1 p2 = body where decs }@
deriving( Show, Eq, Ord, Data, Generic )
@@ -2273,6 +2274,7 @@ data Exp
-- See "Language.Haskell.TH.Syntax#infix"
| LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@
| LamCaseE [Match] -- ^ @{ \\case m1; m2 }@
+ | LamCasesE [Clause] -- ^ @{ \\cases m1; m2 }@
| TupE [Maybe Exp] -- ^ @{ (e1,e2) } @
--
-- The 'Maybe' is necessary for handling
diff --git a/testsuite/tests/arrows/should_fail/T20768_arrow_fail.hs b/testsuite/tests/arrows/should_fail/T20768_arrow_fail.hs
new file mode 100644
index 0000000000..3b35efb366
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/T20768_arrow_fail.hs
@@ -0,0 +1,29 @@
+{-# Language LambdaCase, Arrows #-}
+
+import Control.Arrow
+
+main = return ()
+
+baz :: ArrowChoice p => p (Maybe Int) String
+baz = proc x ->
+ (| id (\cases
+ Just x | x > 100 -> returnA -< "big " ++ show x
+ 1 2 | otherwise -> returnA -< "small " ++ show x
+ -> returnA -< "none")
+ |) x
+
+foo :: Arrow p => p (Maybe Int) String
+foo = proc x ->
+ (| id (\cases
+ (Just x) | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing -> returnA -< "none")
+ |) x
+
+bar :: ArrowChoice p => p (Maybe Int) String
+bar = proc x ->
+ (| id (\cases
+ (Just x) | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing -> returnA -< "none")
+ |) (Just x)
diff --git a/testsuite/tests/arrows/should_fail/T20768_arrow_fail.stderr b/testsuite/tests/arrows/should_fail/T20768_arrow_fail.stderr
new file mode 100644
index 0000000000..b20fc2b03a
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/T20768_arrow_fail.stderr
@@ -0,0 +1,66 @@
+
+T20768_arrow_fail.hs:9:10:
+ /cases alternatives within arrow notation have different numbers of arguments
+ T20768_arrow_fail.hs:10:6-54
+ T20768_arrow_fail.hs:12:6-25
+ In the command: /cases
+ Just x | x > 100 -> returnA -< "big " ++ show x
+ 1 2 | otherwise -> returnA -< "small " ++ show x
+ -> returnA -< "none"
+ In the command: (| id
+ (/cases
+ Just x | x > 100 -> returnA -< "big " ++ show x
+ 1 2 | otherwise -> returnA -< "small " ++ show x
+ -> returnA -< "none") |)
+ In the command: (| id
+ (/cases
+ Just x | x > 100 -> returnA -< "big " ++ show x
+ 1 2 | otherwise -> returnA -< "small " ++ show x
+ -> returnA -< "none") |)
+ x
+
+T20768_arrow_fail.hs:17:9:
+ Could not deduce (ArrowChoice p) arising from an arrow command
+ from the context: Arrow p
+ bound by the type signature for:
+ foo :: forall (p :: * -> * -> *). Arrow p => p (Maybe Int) String
+ at T20768_arrow_fail.hs:15:1-38
+ Possible fix:
+ add (ArrowChoice p) to the context of
+ the type signature for:
+ foo :: forall (p :: * -> * -> *). Arrow p => p (Maybe Int) String
+ In the command: (| id
+ (/cases
+ (Just x)
+ | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing -> returnA -< "none") |)
+ In the command: (| id
+ (/cases
+ (Just x)
+ | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing -> returnA -< "none") |)
+ x
+ In the expression:
+ proc x -> (| id
+ (/cases
+ (Just x)
+ | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing -> returnA -< "none") |)
+ x
+
+T20768_arrow_fail.hs:26:21:
+ Could not deduce (Num (Maybe Int)) arising from the literal ‘100’
+ from the context: ArrowChoice p
+ bound by the type signature for:
+ bar :: forall (p :: * -> * -> *).
+ ArrowChoice p =>
+ p (Maybe Int) String
+ at T20768_arrow_fail.hs:23:1-44
+ In the second argument of ‘(>)’, namely ‘100’
+ In the expression: x > 100
+ In a stmt of a pattern guard for
+ a /cases alternative within arrow notation:
+ x > 100
diff --git a/testsuite/tests/arrows/should_fail/all.T b/testsuite/tests/arrows/should_fail/all.T
index ba8e07440f..382f00aac0 100644
--- a/testsuite/tests/arrows/should_fail/all.T
+++ b/testsuite/tests/arrows/should_fail/all.T
@@ -3,3 +3,4 @@ test('arrowfail003', normal, compile_fail, [''])
test('arrowfail004', normal, compile_fail, [''])
test('T2111', normal, compile_fail, [''])
test('T5380', normal, compile_fail, [''])
+test('T20768_arrow_fail', normal, compile_fail, [''])
diff --git a/testsuite/tests/arrows/should_run/ArrowLambdaCase.hs b/testsuite/tests/arrows/should_run/ArrowLambdaCase.hs
index c678339890..1c671e5c8b 100644
--- a/testsuite/tests/arrows/should_run/ArrowLambdaCase.hs
+++ b/testsuite/tests/arrows/should_run/ArrowLambdaCase.hs
@@ -2,12 +2,17 @@
module Main (main) where
import Control.Arrow
+import Data.Function
main :: IO ()
main = do
putStrLn $ foo (Just 42)
putStrLn $ foo (Just 500)
putStrLn $ foo Nothing
+ putStrLn $ map ($ Just 42) [foo, bar] & \cases
+ [foo', bar'] | foo' == bar' -> "success!"
+ | otherwise -> error "failed"
+ putStrLn $ baz 12 1 (Just 42)
foo :: ArrowChoice p => p (Maybe Int) String
foo = proc x ->
@@ -16,3 +21,20 @@ foo = proc x ->
| otherwise -> returnA -< "small " ++ show x
Nothing -> returnA -< "none")
|) x
+
+bar :: ArrowChoice p => p (Maybe Int) String
+bar = proc x ->
+ (| id (\cases
+ (Just x) | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing -> returnA -< "none")
+ |) x
+
+baz :: ArrowChoice p => Int -> Int -> p (Maybe Int) String
+baz a b = proc x ->
+ (| id (\cases
+ (Just x) 12 20 | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ Nothing _ _ -> returnA -< "none"
+ _ 12 1 -> returnA -< "less than none")
+ |) x a b
diff --git a/testsuite/tests/arrows/should_run/ArrowLambdaCase.stdout b/testsuite/tests/arrows/should_run/ArrowLambdaCase.stdout
index 09e50cf6d7..d61b497aee 100644
--- a/testsuite/tests/arrows/should_run/ArrowLambdaCase.stdout
+++ b/testsuite/tests/arrows/should_run/ArrowLambdaCase.stdout
@@ -1,3 +1,5 @@
small 42
big 500
none
+success!
+less than none
diff --git a/testsuite/tests/corelint/T21115b.stderr b/testsuite/tests/corelint/T21115b.stderr
index 8833208b19..eaa70cc22f 100644
--- a/testsuite/tests/corelint/T21115b.stderr
+++ b/testsuite/tests/corelint/T21115b.stderr
@@ -19,7 +19,7 @@ foo
let {
fail
= \ ds ->
- case patError "T21115b.hs:(10,4)-(15,4)|case"# of wild { } } in
+ case patError "T21115b.hs:(10,4)-(15,4)|\\case"# of wild { } } in
let { fail = \ ds -> 5# } in
case ds of ds {
__DEFAULT -> fail void#;
@@ -31,7 +31,5 @@ end Rec }
*** End of Offense ***
-<no location info>: error:
+<no location info>: error:
Compilation had errors
-
-
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr
index 93a3c99d49..f6d7dca47a 100644
--- a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr
@@ -1,6 +1,6 @@
NoBlockArgumentsFail3.hs:7:22: error:
- Unexpected lambda-case expression in function application:
+ Unexpected \case expression in function application:
\case Just 3 -> print x
Suggested fixes:
Use parentheses.
diff --git a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
index df4cb72d0f..ef1d3d6b83 100644
--- a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
+++ b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
@@ -1,3 +1,3 @@
ParserNoLambdaCase.hs:3:6:
- Illegal lambda-case
+ Illegal \case
Suggested fix: Perhaps you intended to use LambdaCase
diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr
index e928638539..b4460b9cce 100644
--- a/testsuite/tests/parser/should_fail/T16270.stderr
+++ b/testsuite/tests/parser/should_fail/T16270.stderr
@@ -26,18 +26,17 @@ T16270.hs:14:8: error:
Perhaps you intended to use BlockArguments
T16270.hs:18:22: error:
- Illegal record syntax: {fst :: a,
- snd :: b}
+ Illegal record syntax: {fst :: a, snd :: b}
Suggested fix: Perhaps you intended to use TraditionalRecordSyntax
T16270.hs:19:5: error:
- Illegal record syntax: p {fst = 1,
- snd = True}
+ Illegal record syntax: p {fst = 1, snd = True}
Suggested fix: Perhaps you intended to use TraditionalRecordSyntax
T16270.hs:21:6: error:
Illegal symbol ‘forall’ in type
- Suggested fix: Perhaps you intended to use RankNTypes
+ Suggested fix:
+ Perhaps you intended to use RankNTypes
or a similar language extension to enable explicit-forall syntax: forall <tvs>. <type>
T16270.hs:22:8: error:
@@ -47,7 +46,8 @@ T16270.hs:22:8: error:
T16270.hs:24:10: error:
Illegal keyword 'where' in data declaration
- Suggested fix: Perhaps you intended to use GADTs
+ Suggested fix:
+ Perhaps you intended to use GADTs
or a similar language extension to enable syntax: data T where
T16270.hs:26:12: error:
@@ -64,7 +64,7 @@ T16270.hs:30:9: error:
Suggested fix: Perhaps you intended to use MultiWayIf
T16270.hs:33:6:
- Illegal lambda-case
+ Illegal \case
Suggested fix: Perhaps you intended to use LambdaCase
T16270.hs:36:5: error:
@@ -74,8 +74,7 @@ T16270.hs:36:5: error:
T16270.hs:38:5: error:
primitive string literal must contain only characters <= '\xFF'
-T16270.hs:40:7: error:
- A lambda requires at least one parameter
+T16270.hs:40:7: error: A lambda requires at least one parameter
T16270.hs:46:1: error:
parse error (possibly incorrect indentation or mismatched brackets)
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.hs b/testsuite/tests/perf/compiler/hard_hole_fits.hs
index c59fe1b0dd..250c96e5ff 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.hs
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.hs
@@ -18,7 +18,7 @@ testMe (HsIPVar xv hin) = _
testMe (HsOverLit xole hol) = _
testMe (HsLit xle hl) = _
testMe (HsLam xl mg) = _
-testMe (HsLamCase xlc mg) = _
+testMe (HsLamCase xlc lc_variant mg) = _
testMe (HsApp xa gl gl') = _
testMe (HsAppType xate gl hwcb) = _
testMe (OpApp xoa gl gl' gl2) = _
@@ -44,4 +44,3 @@ testMe (HsSpliceE xse hs) = _
testMe (HsProc xp pat gl) = _
testMe (HsStatic xs gl) = _
testMe (XExpr xe) = _
-
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
index 4b59171506..55c267076d 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
@@ -132,12 +132,14 @@ hard_hole_fits.hs:20:24: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:21:29: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:21:40: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
- • In an equation for ‘testMe’: testMe (HsLamCase xlc mg) = _
+ • In an equation for ‘testMe’:
+ testMe (HsLamCase xlc lc_variant mg) = _
• Relevant bindings include
mg :: MatchGroup GhcPs (LHsExpr GhcPs)
- (bound at hard_hole_fits.hs:21:23)
+ (bound at hard_hole_fits.hs:21:34)
+ lc_variant :: LamCaseVariant (bound at hard_hole_fits.hs:21:23)
xlc :: Language.Haskell.Syntax.Extension.XLamCase GhcPs
(bound at hard_hole_fits.hs:21:19)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr
index cd00f26f8b..2ec7564492 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr
@@ -1,7 +1,7 @@
EmptyCase001.hs:9:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘Int’ not matched: _
+ In a \case alternative: Patterns of type ‘Int’ not matched: _
EmptyCase001.hs:14:8: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr
index 691c62b79d..aac509d1f1 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr
@@ -1,25 +1,25 @@
EmptyCase002.hs:16:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘T’ not matched: MkT _
+ In a \case alternative: Patterns of type ‘T’ not matched: MkT _
EmptyCase002.hs:43:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘T1 B’ not matched:
MkT1 B1
MkT1 B2
EmptyCase002.hs:47:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘T1 (E Int)’ not matched:
MkT1 False
MkT1 True
EmptyCase002.hs:51:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘T1
(T2 (T1 (D (E Int) (E (E Int)))))’ not matched:
MkT1 (MkT2 (MkT1 D2))
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase003.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase003.stderr
index e9f6e27cd3..11c2addfa3 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase003.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase003.stderr
@@ -1,12 +1,12 @@
EmptyCase003.hs:15:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘A a’ not matched: _
+ In a \case alternative: Patterns of type ‘A a’ not matched: _
EmptyCase003.hs:32:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘C a’ not matched: _
+ In a \case alternative: Patterns of type ‘C a’ not matched: _
EmptyCase003.hs:37:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘C Int’ not matched: _
+ In a \case alternative: Patterns of type ‘C Int’ not matched: _
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr
index 7dc717c934..9491cc06df 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr
@@ -1,11 +1,11 @@
EmptyCase004.hs:15:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘A Bool’ not matched: A2
+ In a \case alternative: Patterns of type ‘A Bool’ not matched: A2
EmptyCase004.hs:19:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘A a’ not matched:
A1
A2
@@ -16,22 +16,22 @@ EmptyCase004.hs:31:8: warning: [-Wincomplete-patterns (in -Wextra)]
EmptyCase004.hs:35:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘B a b’ not matched:
B1 _
B2
EmptyCase004.hs:47:6: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘A a’ not matched:
A1
A2
EmptyCase004.hs:50:9: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘B a b’ not matched: B2
+ In a \case alternative: Patterns of type ‘B a b’ not matched: B2
EmptyCase004.hs:51:9: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative: Patterns of type ‘B a b’ not matched: B1 _
+ In a \case alternative: Patterns of type ‘B a b’ not matched: B1 _
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr
index 9062f1c40a..7c75c73115 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr
@@ -1,12 +1,12 @@
EmptyCase006.hs:18:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo1 Int’ not matched: Foo1 MkGA1
EmptyCase006.hs:26:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo1 a’ not matched:
Foo1 MkGA1
Foo1 (MkGA2 _)
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr
index 7adef0854a..14693dcdcb 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr
@@ -1,22 +1,22 @@
EmptyCase007.hs:21:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo2 a’ not matched: Foo2 _
EmptyCase007.hs:25:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo2 (a, a)’ not matched: Foo2 _
EmptyCase007.hs:33:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo2 Int’ not matched: Foo2 (_, _)
EmptyCase007.hs:37:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo2 Char’ not matched: Foo2 _
EmptyCase007.hs:44:17: warning: [-Wincomplete-patterns (in -Wextra)]
@@ -25,7 +25,7 @@ EmptyCase007.hs:44:17: warning: [-Wincomplete-patterns (in -Wextra)]
EmptyCase007.hs:48:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo2 [Int]’ not matched:
Foo2 []
Foo2 (_:_)
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr
index c826a05569..66e70e0a7e 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr
@@ -1,22 +1,22 @@
EmptyCase008.hs:17:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo3 Int’ not matched:
Foo3 (MkDA1 _)
Foo3 MkDA2
EmptyCase008.hs:21:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo3 a’ not matched: Foo3 _
EmptyCase008.hs:40:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo4 Int ()’ not matched: Foo4 MkDB1
EmptyCase008.hs:48:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Foo4 a b’ not matched: Foo4 _
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr
index ca6ca03e9f..622493b446 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr
@@ -5,10 +5,10 @@ EmptyCase009.hs:21:9: warning: [-Wincomplete-patterns (in -Wextra)]
EmptyCase009.hs:33:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Bar (DB ())’ not matched: Bar MkDB2_u
EmptyCase009.hs:42:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Bar GB’ not matched: Bar MkGB3
diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr
index 8202c65a22..0672f17f69 100644
--- a/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr
+++ b/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr
@@ -1,19 +1,19 @@
EmptyCase010.hs:24:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Baz GC a’ not matched:
Baz MkGC1
Baz (MkGC2 _)
EmptyCase010.hs:28:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Baz GC 'T1’ not matched: Baz MkGC1
EmptyCase010.hs:37:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Baz GD Maybe’ not matched:
Baz MkGD1
Baz MkGD3
@@ -25,7 +25,7 @@ EmptyCase010.hs:41:9: warning: [-Wincomplete-patterns (in -Wextra)]
EmptyCase010.hs:45:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Baz GD f’ not matched:
Baz MkGD1
Baz MkGD2
@@ -33,12 +33,12 @@ EmptyCase010.hs:45:7: warning: [-Wincomplete-patterns (in -Wextra)]
EmptyCase010.hs:57:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Baz (DC ()) a’ not matched: Baz _
EmptyCase010.hs:69:7: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
+ In a \case alternative:
Patterns of type ‘Baz (DC Bool) [Int]’ not matched: Baz MkDC2
EmptyCase010.hs:73:9: warning: [-Wincomplete-patterns (in -Wextra)]
diff --git a/testsuite/tests/printer/Ppr020.hs b/testsuite/tests/printer/Ppr020.hs
index f567f726a1..d930a73ac3 100644
--- a/testsuite/tests/printer/Ppr020.hs
+++ b/testsuite/tests/printer/Ppr020.hs
@@ -4,6 +4,14 @@ foo = f >>= \case
Just h -> loadTestDB (h ++ "/.testdb")
Nothing -> fmap S.Right initTestDB
+foo = f >>= \cases
+ x (Just h) -> loadTestDB (h ++ "/.testdb")
+ _ Nothing -> fmap S.Right initTestDB
+
+foo = f >>= \cases
+ | a -> loadTestDB (h ++ "/.testdb")
+ | b -> fmap S.Right initTestDB
+
{-| Is the alarm set - i.e. will it go off at some point in the future even if
`setAlarm` is not called? -}
isAlarmSetSTM :: AlarmClock -> STM Bool
diff --git a/testsuite/tests/printer/PprArrowLambdaCase.hs b/testsuite/tests/printer/PprArrowLambdaCase.hs
index c678339890..9760d1372e 100644
--- a/testsuite/tests/printer/PprArrowLambdaCase.hs
+++ b/testsuite/tests/printer/PprArrowLambdaCase.hs
@@ -16,3 +16,11 @@ foo = proc x ->
| otherwise -> returnA -< "small " ++ show x
Nothing -> returnA -< "none")
|) x
+
+foo :: ArrowChoice p => p (Maybe Int) String
+foo = proc x ->
+ (| id (\cases
+ y (Just x) | x > 100 -> returnA -< "big " ++ show x
+ | otherwise -> returnA -< "small " ++ show x
+ _ Nothing -> returnA -< "none")
+ |) 1 x
diff --git a/testsuite/tests/rep-poly/RepPolyMatch.stderr b/testsuite/tests/rep-poly/RepPolyMatch.stderr
index 420c38efe2..d845426032 100644
--- a/testsuite/tests/rep-poly/RepPolyMatch.stderr
+++ b/testsuite/tests/rep-poly/RepPolyMatch.stderr
@@ -1,6 +1,6 @@
RepPolyMatch.hs:11:9: error:
- • The binder of the lambda-case expression
+ • The binder of the \case expression
does not have a fixed runtime representation.
Its type is:
a :: TYPE rep
diff --git a/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs b/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs
index a1cbec4b59..b74aeb4eae 100644
--- a/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs
+++ b/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs
@@ -18,7 +18,7 @@ testMe (HsIPVar xv hin) = _
testMe (HsOverLit xole hol) = _
testMe (HsLit xle hl) = _
testMe (HsLam xl mg) = _
-testMe (HsLamCase xlc mg) = _
+testMe (HsLamCase xlc lc_variant mg) = _
testMe (HsApp xa gl gl') = _
testMe (HsAppType xate gl hwcb) = _
testMe (OpApp xoa gl gl' gl2) = _
@@ -45,4 +45,3 @@ testMe (HsSpliceE xse hs) = _
testMe (HsProc xp pat gl) = _
testMe (HsStatic xs gl) = _
testMe (XExpr xe) = _
-
diff --git a/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr
index 78a3584f1c..672cca7440 100644
--- a/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr
+++ b/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr
@@ -134,7 +134,7 @@ hard_hole_fits.hs:20:24: warning: [-Wtyped-holes (in -Wdefault)]
hard_hole_fits.hs:21:29: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
- • In an equation for ‘testMe’: testMe (HsLamCase xlc mg) = _
+ • In an equation for ‘testMe’: testMe (HsLamCase xlc lc_variant mg) = _
• Relevant bindings include
mg :: MatchGroup GhcPs (LHsExpr GhcPs)
(bound at hard_hole_fits.hs:21:23)
diff --git a/testsuite/tests/typecheck/should_fail/T20768_fail.hs b/testsuite/tests/typecheck/should_fail/T20768_fail.hs
new file mode 100644
index 0000000000..c2531f2075
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T20768_fail.hs
@@ -0,0 +1,12 @@
+{-# language LambdaCase #-}
+
+module Main where
+
+import Data.Function
+
+bar = \cases | 'c' -> "foo"
+
+main = (\cases 1 2 -> return ()) "foo"
+
+foo = 1 & \cases 1 2 -> return ()
+ 1 -> return ()
diff --git a/testsuite/tests/typecheck/should_fail/T20768_fail.stderr b/testsuite/tests/typecheck/should_fail/T20768_fail.stderr
new file mode 100644
index 0000000000..86bb3b5216
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T20768_fail.stderr
@@ -0,0 +1,31 @@
+
+T20768_fail.hs:7:16:
+ Couldn't match expected type ‘Bool’ with actual type ‘Char’
+ In the expression: 'c'
+ In a stmt of a pattern guard for
+ a /cases alternative:
+ 'c'
+ In a /cases alternative: | 'c' -> "foo"
+
+T20768_fail.hs:9:1:
+ Couldn't match expected type: IO t0
+ with actual type: a0 -> m0 ()
+ When checking the type of the IO action ‘main’
+
+T20768_fail.hs:11:11:
+ /cases alternatives have different numbers of arguments
+ T20768_fail.hs:11:18-33
+ T20768_fail.hs:12:18-31
+ In the second argument of ‘(&)’, namely
+ ‘/cases
+ 1 2 -> return ()
+ 1 -> return ()’
+ In the expression:
+ 1 & /cases
+ 1 2 -> return ()
+ 1 -> return ()
+ In an equation for ‘foo’:
+ foo
+ = 1 & /cases
+ 1 2 -> return ()
+ 1 -> return ()
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index a8a4e4d3b5..939d9b156e 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -651,3 +651,4 @@ test('T18406', normal, compile_fail, [''])
test('AmbigFDs', normal, compile_fail, [''])
test('T20064', normal, compile_fail, [''])
test('T21130', normal, compile_fail, [''])
+test('T20768_fail', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_run/T20768.hs b/testsuite/tests/typecheck/should_run/T20768.hs
new file mode 100644
index 0000000000..258604782b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T20768.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import Data.Function
+import GHC.Exts
+
+main :: IO ()
+main = do
+ putStrLn \cases | 1 < 1 -> "foo"
+ | otherwise -> "bar"
+ print $ (\cases 1 _ -> error "no"; x y -> x + y) 4 5
+ (Just 4) & ("23" & \cases
+ "23" Nothing -> print "failed"
+ s (Just x) -> putStrLn $ s ++ show x)
+
+ unboxed 1 2# (# 3, "4"# #)
+
+unboxed :: Int -> Int# -> (# Int, Addr# #) -> IO ()
+unboxed = \cases 1 1# (# 3 , s #) -> print ()
+ (I# x) y (# (I# z), s #) -> putStrLn $ show (I# (x +# y +# z)) ++ unpackCString# s
diff --git a/testsuite/tests/typecheck/should_run/T20768.stdout b/testsuite/tests/typecheck/should_run/T20768.stdout
new file mode 100644
index 0000000000..93d261ee36
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T20768.stdout
@@ -0,0 +1,4 @@
+bar
+9
+234
+64
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index a465999b58..b4e04a118c 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -162,3 +162,4 @@ test('T19397M2', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
test('T19397M3', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
test('T19667', normal, compile_and_run, ['-fhpc'])
+test('T20768', normal, compile_and_run, [''])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 3d493cfd22..3ea74a569c 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -12,6 +12,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance
module ExactPrint
@@ -1429,7 +1430,9 @@ instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where
-- LambdaExpr -> do
-- markEpAnn an AnnLam
-- mapM_ markAnnotated pats
- -- GHC.CaseAlt -> do
+ -- CaseAlt -> do
+ -- mapM_ markAnnotated pats
+ -- LamCaseAlt _ ->
-- mapM_ markAnnotated pats
-- _ -> withPpr mctxt
@@ -1473,7 +1476,9 @@ exactMatch (Match an mctxt pats grhss) = do
LambdaExpr -> do
markEpAnn an AnnLam
markAnnotated pats
- GHC.CaseAlt -> do
+ CaseAlt -> do
+ markAnnotated pats
+ LamCaseAlt _ -> do
markAnnotated pats
_ -> withPpr mctxt
@@ -1832,7 +1837,7 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsOverLit an _) = fromAnn an
getAnnotationEntry (HsLit an _) = fromAnn an
getAnnotationEntry (HsLam _ _) = NoEntryVal
- getAnnotationEntry (HsLamCase an _) = fromAnn an
+ getAnnotationEntry (HsLamCase an _ _) = fromAnn an
getAnnotationEntry (HsApp an _ _) = fromAnn an
getAnnotationEntry (HsAppType _ _ _) = NoEntryVal
getAnnotationEntry (OpApp an _ _ _) = fromAnn an
@@ -1897,9 +1902,10 @@ instance ExactPrint (HsExpr GhcPs) where
-- markExpr _ (HsLam _ _) = error $ "HsLam with other than one match"
exact (HsLam _ _) = error $ "HsLam with other than one match"
- exact (HsLamCase an mg) = do
+ exact (HsLamCase an lc_variant mg) = do
markEpAnn an AnnLam
- markEpAnn an AnnCase
+ markEpAnn an case lc_variant of LamCase -> AnnCase
+ LamCases -> AnnCases
markAnnotated mg
exact (HsApp _an e1 e2) = do
@@ -2317,7 +2323,7 @@ instance ExactPrint (HsCmd GhcPs) where
getAnnotationEntry (HsCmdLam {}) = NoEntryVal
getAnnotationEntry (HsCmdPar an _ _ _) = fromAnn an
getAnnotationEntry (HsCmdCase an _ _) = fromAnn an
- getAnnotationEntry (HsCmdLamCase an _) = fromAnn an
+ getAnnotationEntry (HsCmdLamCase an _ _) = fromAnn an
getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an
getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an
getAnnotationEntry (HsCmdDo an _) = fromAnn an
@@ -2368,9 +2374,10 @@ instance ExactPrint (HsCmd GhcPs) where
markAnnotated alts
markEpAnn' an hsCaseAnnsRest AnnCloseC
- exact (HsCmdLamCase an matches) = do
+ exact (HsCmdLamCase an lc_variant matches) = do
markEpAnn an AnnLam
- markEpAnn an AnnCase
+ markEpAnn an case lc_variant of LamCase -> AnnCase
+ LamCases -> AnnCases
markAnnotated matches
exact (HsCmdIf an _ e1 e2 e3) = do
diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs
index 18e4e32f6f..3cd53be04c 100644
--- a/utils/check-exact/Lookup.hs
+++ b/utils/check-exact/Lookup.hs
@@ -38,6 +38,7 @@ keywordToString kw =
(G AnnBackquote ) -> "`"
(G AnnBy ) -> "by"
(G AnnCase ) -> "case"
+ (G AnnCases ) -> "cases"
(G AnnClass ) -> "class"
(G AnnCloseB ) -> "|)"
(G AnnCloseBU ) -> "⦈"
diff --git a/utils/haddock b/utils/haddock
-Subproject 58237d76c96325f25627bfd7cdad5b93364d29a
+Subproject fb0e9bac0a5297f995b151f25aa1ce3e622e12e