diff options
| author | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-03-21 00:14:25 +0100 |
|---|---|---|
| committer | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-04-01 20:31:08 +0200 |
| commit | 32070e6c2e1b4b7c32530a9566fe14543791f9a6 (patch) | |
| tree | f0913ef2a69fd660542723ec07240167dbd37961 | |
| parent | d85c7dcb7c457efc23b20ac8f4e4ae88bae5b050 (diff) | |
| download | haskell-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
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 |