summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/HsToCore')
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs202
-rw-r--r--compiler/GHC/HsToCore/Binds.hs4
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs30
-rw-r--r--compiler/GHC/HsToCore/Expr.hs14
-rw-r--r--compiler/GHC/HsToCore/Match.hs37
-rw-r--r--compiler/GHC/HsToCore/Match.hs-boot2
-rw-r--r--compiler/GHC/HsToCore/Pmc.hs29
-rw-r--r--compiler/GHC/HsToCore/Pmc/Utils.hs30
-rw-r--r--compiler/GHC/HsToCore/Quote.hs9
-rw-r--r--compiler/GHC/HsToCore/Utils.hs1
10 files changed, 230 insertions, 128 deletions
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 e1e8489fe1..8fececdcea 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 22fc242e87..109df1a103 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 #-}
View Lorry Controller Status