From 6a4a66d17abbd22a687fc9fc0d99734114156756 Mon Sep 17 00:00:00 2001
From: Apoorv Ingle <apoorv-ingle@uiowa.edu>
Date: Tue, 30 Jan 2024 19:52:30 -0600
Subject: [PATCH] towards killing GenReason
---
compiler/GHC/Hs/Instances.hs | 2 +
compiler/GHC/Hs/Pat.hs | 6 +--
compiler/GHC/Hs/Utils.hs | 10 ++---
compiler/GHC/HsToCore/Arrows.hs | 2 +-
compiler/GHC/HsToCore/Expr.hs | 2 +-
compiler/GHC/HsToCore/Match.hs | 38 ++++++++-----------
compiler/GHC/HsToCore/Pmc.hs | 35 +++++++++++++----
compiler/GHC/HsToCore/Ticks.hs | 5 ++-
compiler/GHC/Rename/Utils.hs | 4 +-
compiler/GHC/Tc/Deriv/Generate.hs | 6 +--
compiler/GHC/Tc/Gen/Do.hs | 5 +--
compiler/GHC/Tc/Gen/Expr.hs | 2 +-
compiler/GHC/Tc/Gen/Match.hs | 5 ++-
compiler/GHC/Tc/Gen/Splice.hs | 2 +-
compiler/GHC/Tc/TyCl/Instance.hs | 2 +-
compiler/GHC/Tc/TyCl/PatSyn.hs | 4 +-
compiler/GHC/Tc/TyCl/Utils.hs | 2 +-
compiler/GHC/Types/Basic.hs | 36 ++----------------
compiler/Language/Haskell/Syntax/Expr.hs | 1 -
compiler/Language/Haskell/Syntax/Expr.hs-boot | 7 ----
testsuite/tests/ghc-api/T18522-dbg-ppr.hs | 2 +-
21 files changed, 78 insertions(+), 100 deletions(-)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index b06b64e3de56..a70b88cfbc1f 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -388,6 +388,8 @@ deriving instance Data (HsStmtContext GhcTc)
deriving instance Data HsArrowMatchContext
+deriving instance Data HsDoFlavour
+
deriving instance Data (HsMatchContext GhcPs)
deriving instance Data (HsMatchContext GhcRn)
deriving instance Data (HsMatchContext GhcTc)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 5d0e90a5ef69..68ae8b08fcc3 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -40,7 +40,7 @@ module GHC.Hs.Pat (
mkPrefixConPat, mkCharLitPat, mkNilPat,
- isSimplePat, isPatSyn,
+ isSimplePat,
looksLazyPatBind,
isBangedLPat,
gParPat, patNeedsParens, parenthesizePat,
@@ -703,10 +703,6 @@ isBoringHsPat = goL
CoPat _ pat _ -> go pat
ExpansionPat _ pat -> go pat
-isPatSyn :: LPat GhcTc -> Bool
-isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True
-isPatSyn _ = False
-
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 49b6c4decdb1..9611923e6981 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -275,7 +275,7 @@ mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
-> LHsExpr (GhcPass p)
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))
where
- matches = mkMatchGroup (Generated OtherExpansion SkipPmc)
+ matches = mkMatchGroup (Generated SkipPmc)
(noLocA [mkSimpleMatch (LamAlt LamSingle) pats' body])
pats' = map (parenthesizePat appPrec) pats
@@ -611,7 +611,7 @@ nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-- AZ:Is this used?
nlHsLam match = noLocA $ HsLam noAnn LamSingle
- $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])
+ $ mkMatchGroup (Generated SkipPmc) (noLocA [match])
nlHsPar e = noLocA (gHsPar e)
@@ -621,8 +621,8 @@ nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
nlHsCase expr matches
- = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches)))
-nlList exprs = noLocA (ExplicitList noAnn exprs)
+ = noLocA (HsCase noAnn expr (mkMatchGroup (Generated SkipPmc) (noLocA matches)))
+nlList exprs = noLocA (ExplicitList noAnn exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IsSrcSpanAnn p a
@@ -893,7 +893,7 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind loc fun pats expr
- = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)
+ = L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun)
[mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
emptyLocalBinds]
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 37c8678f9cdf..370bbe9afbbe 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -810,7 +810,7 @@ dsCases ids local_vars stack_id stack_ty res_ty
Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
dsExpr (HsLam noAnn LamCase
(MG { mg_alts = noLocA []
- , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion SkipPmc)
+ , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated SkipPmc)
}))
-- Replace the commands in the case with these tagged tuples,
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index a0c211552848..a6cc26f2da68 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -832,7 +832,7 @@ dsDo ctx stmts
later_pats = rec_tup_pats
rets = map noLocA rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
- match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion SkipPmc)
+ match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated SkipPmc)
mfix_arg = noLocA $ HsLam noAnn LamSingle
(MG { mg_alts = noLocA [mkSimpleMatch
(LamAlt LamSingle)
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index a0905f5559cc..ab6513ff9183 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -29,7 +29,7 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), requiresPMC, isDoExpansionGenerated )
+import GHC.Types.Basic ( Origin(..), requiresPMC, isGenerated)
import GHC.Types.SourceText
( FractionalLit,
@@ -765,20 +765,11 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
-}
-matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
+matchWrapper ctxt' scrs (MG { mg_alts = L _ matches
, mg_ext = MatchGroupTc arg_tys rhs_ty origin
})
= do { dflags <- getDynFlags
; locn <- getSrcSpanDs
- ; let matches
- = if any (is_pat_syn_match origin) matches'
- then filter (non_gen_wc origin) matches'
- -- filter out the wild pattern fail alternatives
- -- which have a do expansion origin
- -- They generate spurious overlapping warnings
- -- Due to pattern synonyms treated as refutable patterns
- -- See Part 1's Wrinkle 1 in Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
- else matches'
; new_vars <- case matches of
[] -> newSysLocalsDs arg_tys
(m:_) ->
@@ -786,7 +777,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
(\a b -> (scaledMult a, unLoc b))
arg_tys
(hsLMatchPats m))
-
+ ; let ctxt = mkActualMatchCtxt ctxt' origin matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
@@ -808,7 +799,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
else do { ldi_nablas <- getLdiNablas
; pure $ initNablasMatches ldi_nablas matches }
- ; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
+ ; eqns_info <- zipWithM (mk_eqn_info ctxt) matches matches_nablas
; result_expr <- discard_warnings_if_skip_pmc origin $
matchEquations ctxt new_vars eqns_info rhs_ty
@@ -816,8 +807,8 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
; return (new_vars, result_expr) }
where
-- Called once per equation in the match, or alternative in the case
- mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
- mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
+ mk_eqn_info :: HsMatchContext GhcTc -> LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
+ mk_eqn_info ctxt (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
= do { dflags <- getDynFlags
; let upats = map (decideBangHood dflags) pats
-- pat_nablas is the covered set *after* matching the pattern, but
@@ -843,13 +834,16 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
$ NEL.nonEmpty
$ replicate (length (grhssGRHSs m)) ldi_nablas
- is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
- is_pat_syn_match origin (L _ (Match _ _ [l_pat] _)) | isDoExpansionGenerated origin = isPatSyn l_pat
- is_pat_syn_match _ _ = False
- -- generated match pattern that is not a wildcard
- non_gen_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
- non_gen_wc origin (L _ (Match _ _ ([L _ (WildPat _)]) _)) = not . isDoExpansionGenerated $ origin
- non_gen_wc _ _ = True
+ -- Is this match compiler generated by expanding a do-block
+ match_ctxt_mb :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Maybe (HsMatchContext GhcTc)
+ match_ctxt_mb origin (L _ match) | e@(StmtCtxt{}) <- m_ctxt match, isGenerated origin = Just e
+ match_ctxt_mb _ _ = Nothing
+
+ mkActualMatchCtxt :: HsMatchContext GhcTc -> Origin -> [LMatch GhcTc (LHsExpr GhcTc)] -> HsMatchContext GhcTc
+ mkActualMatchCtxt d _ [] = d
+ mkActualMatchCtxt d origin (m : ms) | Just x <- match_ctxt_mb origin m = x
+ | otherwise = mkActualMatchCtxt d origin ms
+
{- Note [Long-distance information in matchWrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index fd6d813fc713..98aa56c53fa9 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -51,7 +51,7 @@ import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Pmc.Desugar
import GHC.HsToCore.Pmc.Check
import GHC.HsToCore.Pmc.Solver
-import GHC.Types.Basic (Origin(..), isDoExpansionGenerated)
+import GHC.Types.Basic (Origin(..))
import GHC.Core
import GHC.Driver.DynFlags
import GHC.Hs
@@ -68,7 +68,7 @@ import GHC.HsToCore.Monad
import GHC.Data.Bag
import GHC.Data.OrdList
-import Control.Monad (when, unless, forM_)
+import Control.Monad (when, forM_)
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
@@ -122,6 +122,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
want_pmc (StmtCtxt stmt_ctxt) =
case stmt_ctxt of
PatGuard {} -> False
+ HsDoStmt {} -> False
_ -> True
want_pmc _ = False
@@ -132,7 +133,7 @@ pmcGRHSs
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check
-> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long
-- distance info
-pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
+pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = mb_discard_warnings $ do
let combined_loc = foldl1 combineSrcSpans (map getLocA grhss)
ctxt = DsMatchContext hs_ctxt combined_loc
!missing <- getLdiNablas
@@ -145,6 +146,14 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
tracePm "}: " (ppr (cr_uncov result))
formatReportWarnings ReportGRHSs ctxt [] result
return (ldiGRHSs (cr_ret result))
+ where
+ mb_discard_warnings
+ = if want_pmc hs_ctxt
+ then id
+ else discardWarningsDs
+ want_pmc mctxt | (StmtCtxt (HsDoStmt{})) <- mctxt
+ = False
+ | otherwise = True
-- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each
-- with a 'Pat' and one or more 'GRHSs':
@@ -168,13 +177,13 @@ pmcMatches
-> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches
-> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and
-- GRHS, for long distance info.
-pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
+pmcMatches origin ctxt@(DsMatchContext match_ctxt _) vars matches = mb_discard_warnings $ {-# SCC "pmcMatches" #-} do
-- We have to force @missing@ before printing out the trace message,
-- otherwise we get interleaved output from the solver. This function
-- should be strict in @missing@ anyway!
!missing <- getLdiNablas
tracePm "pmcMatches {" $
- hang (vcat [ppr origin, ppr ctxt, ppr vars, text "Matches:"])
+ hang (vcat [ppr origin, ppr ctxt, ppr ctxt, ppr vars, text "Matches:"])
2
((ppr matches) $$ (text "missing:" <+> ppr missing))
case NE.nonEmpty matches of
@@ -192,10 +201,20 @@ pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
result <- {-# SCC "checkMatchGroup" #-}
unCA (checkMatchGroup matches) missing
tracePm "}: " (ppr (cr_uncov result))
- unless (isDoExpansionGenerated origin) -- Do expansion generated code shouldn't emit overlapping warnings
- ({-# SCC "formatReportWarnings" #-}
- formatReportWarnings ReportMatchGroup ctxt vars result)
+ {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
return (NE.toList (ldiMatchGroup (cr_ret result)))
+ where
+ mb_discard_warnings
+ = if want_pmc match_ctxt
+ then id
+ else discardWarningsDs
+ -- We want to discard the warnings that may arise due to
+ -- compiler generated fail blocks for do-expansions and pattern synonyms
+ -- See. Note
+ want_pmc mctxt | (StmtCtxt (HsDoStmt{})) <- mctxt
+ = False
+ | otherwise = True
+
{-
Note [Detecting incomplete record selectors]
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index 5c93f9dbebed..d4d9edeadc05 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -635,9 +635,12 @@ addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do
let isOneOfMany = matchesOneOfMany matches
- isDoExp = isDoExpansionGenerated $ mg_origin ctxt
+ isDoExp = any is_match_do_gen $ fmap unLoc matches
matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches
return $ mg { mg_alts = L l matches' }
+ where
+ is_match_do_gen m | StmtCtxt{} <- m_ctxt m = isGenerated (mg_origin ctxt)
+ is_match_do_gen _ = False
addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index ea01e8195741..369702939bbc 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -780,7 +780,7 @@ genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
genFunBind fn ms
= FunBind { fun_id = fn
- , fun_matches = mkMatchGroup (Generated OtherExpansion SkipPmc) (wrapGenSpan ms)
+ , fun_matches = mkMatchGroup (Generated SkipPmc) (wrapGenSpan ms)
, fun_ext = emptyNameSet
}
@@ -798,7 +798,7 @@ genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
-> LHsExpr (GhcPass p)
genHsLamDoExp doFlav pats body = mkHsPar (wrapGenSpan $ HsLam noAnn LamSingle matches)
where
- matches = mkMatchGroup (doExpansionOrigin doFlav)
+ matches = mkMatchGroup (Generated SkipPmc)
(wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) pats' body])
pats' = map (parenthesizePat appPrec) pats
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index ac40a1d1bcea..ac62cf384d45 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -2292,7 +2292,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
- = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches)
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches)
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
@@ -2320,7 +2320,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2344,7 +2344,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
- = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Gen/Do.hs b/compiler/GHC/Tc/Gen/Do.hs
index 12631e13814a..25d11db09b16 100644
--- a/compiler/GHC/Tc/Gen/Do.hs
+++ b/compiler/GHC/Tc/Gen/Do.hs
@@ -212,7 +212,7 @@ mk_failable_expr doFlav pat@(L loc _) expr fail_op =
mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
+ return $ HsLam noAnn LamCases $ mkMatchGroup (Generated SkipPmc) -- \
(wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
, fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern"
])
@@ -470,6 +470,5 @@ It stores the original statement (with location) and the expanded expression
However, the expansion lambda `(\p -> e2)` is special as it is generated from a `do`-stmt expansion
and if a type checker error occurs in the pattern `p` (which is source generated), we need to say
"in a pattern binding in a do block" and not "in the pattern of a lambda" (cf. Typeable1.hs).
- We hence use a tag `GenReason` in `Ghc.Tc.Origin`. When typechecking a `HsLam` in `Tc.Gen.Expr.tcExpr`
- the `match_ctxt` is set to a `StmtCtxt` if `GenOrigin` is a `DoExpansionOrigin`.
+ This warning is governed by `m_ctxt` stored in `Match` which is set to `StmtCtxt (HsDoStmt doFlav)` c.f.
-}
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index b63e0862af10..9083123a8de0 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -1342,7 +1342,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
case_expr :: HsExpr GhcRn
case_expr = HsCase RecUpd record_expr
- $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches)
+ $ mkMatchGroup (Generated DoPmc) (wrapGenSpan matches)
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = map make_pat relevant_cons
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index d216e80e3336..4a1bd149cd54 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -169,13 +169,16 @@ tcMatchLambda herald match res_ty
| otherwise = matchGroupArity match
match_alt_checker
- | isDoExpansionGenerated (mg_ext match)
+ | any (match_is_do_gen $ mg_ext match) (fmap unLoc $ unLoc (mg_alts match))
-- See Part 3. B. of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`. Testcase: Typeable1
= tcBodyNC -- NB: Do not add any error contexts
-- It has already been done
| otherwise
= tcBody
+ match_is_do_gen o m | (StmtCtxt (HsDoStmt{})) <- m_ctxt m = isGenerated o
+ match_is_do_gen _ _ = False
+
-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 45640c16c5ae..46a4721db9c5 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1976,7 +1976,7 @@ lookupName is_type_name s
getThSpliceOrigin :: TcM Origin
getThSpliceOrigin = do
warn <- goptM Opt_EnableThSpliceWarnings
- if warn then return FromSource else return (Generated OtherExpansion SkipPmc)
+ if warn then return FromSource else return (Generated SkipPmc)
getThing :: TH.Name -> TcM TcTyThing
getThing th_name
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f41cd8e9d07b..f721dc789f3f 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2219,7 +2219,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
, tyConBinderForAllTyFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
bind = L (noAnnSrcSpan loc)
- $ mkTopFunBind (Generated OtherExpansion SkipPmc) fn
+ $ mkTopFunBind (Generated SkipPmc) fn
[mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index f3b0a7c2a33d..d15e2829a6d9 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -792,7 +792,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
then [mkHsCaseAlt lpat cont']
else [mkHsCaseAlt lpat cont',
mkHsCaseAlt lwpat fail']
- gen = Generated OtherExpansion SkipPmc
+ gen = Generated SkipPmc
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
HsCase PatSyn (nlHsVar scrutinee) $
@@ -941,7 +941,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
- mk_mg body = mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [builder_match])
+ mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match])
where
builder_args = [L (l2l loc) (VarPat noExtField (L loc n))
| L loc n <- args]
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index aac22b5cff35..2592d1efbf2f 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -933,7 +933,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
-- where cons_w_field = [C2,C7]
- sel_bind = mkTopFunBind (Generated OtherExpansion SkipPmc) sel_lname alts
+ sel_bind = mkTopFunBind (Generated SkipPmc) sel_lname alts
where
alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
[] unit_rhs]
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 45c353895a6e..54d2c6e56daf 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -38,8 +38,6 @@ module GHC.Types.Basic (
RecFlag(..), isRec, isNonRec, boolToRecFlag,
Origin(..), isGenerated, DoPmc(..), requiresPMC,
- GenReason(..), isDoExpansionGenerated, doExpansionFlavour,
- doExpansionOrigin,
RuleName, pprRuleName,
@@ -133,7 +131,6 @@ import GHC.Types.SourceText
import qualified GHC.LanguageExtensions as LangExt
import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted)
import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag)
-import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour)
import Control.DeepSeq ( NFData(..) )
import Data.Data
@@ -591,43 +588,16 @@ instance Binary RecFlag where
--
-- See Note [Generated code and pattern-match checking].
data Origin = FromSource
- | Generated GenReason DoPmc
+ | Generated DoPmc
deriving( Eq, Data )
isGenerated :: Origin -> Bool
isGenerated Generated{} = True
isGenerated FromSource = False
--- | This metadata stores the information as to why was the piece of code generated
--- It is useful for generating the right error context
--- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
-data GenReason = DoExpansion HsDoFlavour
- | OtherExpansion
- deriving (Eq, Data)
-
-instance Outputable GenReason where
- ppr DoExpansion{} = text "DoExpansion"
- ppr OtherExpansion = text "OtherExpansion"
-
-doExpansionFlavour :: Origin -> Maybe HsDoFlavour
-doExpansionFlavour (Generated (DoExpansion f) _) = Just f
-doExpansionFlavour _ = Nothing
-
--- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
-isDoExpansionGenerated :: Origin -> Bool
-isDoExpansionGenerated = isJust . doExpansionFlavour
-
--- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
-doExpansionOrigin :: HsDoFlavour -> Origin
-doExpansionOrigin f = Generated (DoExpansion f) DoPmc
- -- It is important that we perfrom PMC
- -- on the expressions generated by do statements
- -- to get the right pattern match checker warnings
- -- See `GHC.HsToCore.Pmc.pmcMatches`
-
instance Outputable Origin where
ppr FromSource = text "FromSource"
- ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc
+ ppr (Generated pmc) = text "Generated" <+> ppr pmc
-- | Whether to run pattern-match checks in generated code.
--
@@ -645,7 +615,7 @@ instance Outputable DoPmc where
--
-- See Note [Generated code and pattern-match checking].
requiresPMC :: Origin -> Bool
-requiresPMC (Generated _ SkipPmc) = False
+requiresPMC (Generated SkipPmc) = False
requiresPMC _ = True
{- Note [Generated code and pattern-match checking]
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 5c732a180155..7fc9635dc934 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1608,7 +1608,6 @@ data HsDoFlavour
| GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
| ListComp
| MonadComp
- deriving (Eq, Data)
qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
qualifiedDoModuleName_maybe ctxt = case ctxt of
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs-boot b/compiler/Language/Haskell/Syntax/Expr.hs-boot
index 1b489a1f4d81..b6a0d7943105 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs-boot
+++ b/compiler/Language/Haskell/Syntax/Expr.hs-boot
@@ -9,9 +9,6 @@ module Language.Haskell.Syntax.Expr where
import Language.Haskell.Syntax.Extension ( XRec )
import Data.Kind ( Type )
-import GHC.Prelude (Eq)
-import Data.Data (Data)
-
type role HsExpr nominal
type role MatchGroup nominal nominal
type role GRHSs nominal nominal
@@ -23,7 +20,3 @@ data GRHSs (a :: Type) (body :: Type)
type family SyntaxExpr (i :: Type)
type LHsExpr a = XRec a (HsExpr a)
-
-data HsDoFlavour
-instance Eq HsDoFlavour
-instance Data HsDoFlavour
\ No newline at end of file
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index 5e5ce6e13aa0..918b39eb90b6 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -44,7 +44,7 @@ main = do
forall (a :: k) (b :: j) ->
() |]
let hs_t = fromRight (error "convertToHsType") $
- convertToHsType (Generated OtherExpansion SkipPmc) noSrcSpan th_t
+ convertToHsType (Generated SkipPmc) noSrcSpan th_t
(messages, mres) <-
tcRnType hsc_env SkolemiseFlexi True hs_t
let (warnings, errors) = partitionMessages messages
--
GitLab