[Git][ghc/ghc][wip/expand-do] disallow overlapping warnings in do expansion generated match equations
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri May 19 19:29:27 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
94811104 by Apoorv Ingle at 2023-05-19T14:29:18-05:00
disallow overlapping warnings in do expansion generated match equations
- - - - -
8 changed files:
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Types/Hint.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -345,8 +345,8 @@ subordinates env instMap decl = case decl of
InstD _ (ClsInstD _ d) -> let
data_fams = do
DataFamInstDecl { dfid_eqn =
- (FamEqn { feqn_tycon = L l _
- , feqn_rhs = defn })} <- unLoc <$> cid_datafam_insts d
+ FamEqn { feqn_tycon = L l _
+ , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d
[ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
ty_fams = do
TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ }) } <- unLoc <$> cid_tyfam_insts d
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -28,7 +28,7 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), isGenerated )
+import GHC.Types.Basic ( Origin(..), isGenerated, GenReason (..))
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Hs
@@ -788,12 +788,13 @@ matchWrapper ctxt scrs (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.
; tracePm "matchWrapper" (vcat [ ppr ctxt
+ , text "scrs" <+> ppr scrs
, text "matches group" <+> ppr matches
, text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)])
; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
then addHsScrutTmCs (concat scrs) new_vars $
-- See Note [Long-distance information]
- pmcMatches (DsMatchContext ctxt locn) new_vars matches
+ pmcMatches origin (DsMatchContext ctxt locn) new_vars matches
else pure (initNablasMatches matches)
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
@@ -814,7 +815,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
; match_result <- updPmNablas pat_nablas $
dsGRHSs ctxt grhss rhs_ty rhss_nablas
; return EqnInfo { eqn_pats = upats
- , eqn_orig = FromSource
+ , eqn_orig = origin -- Not all equations are from source
, eqn_rhs = match_result } }
handleWarnings = if isGenerated origin
@@ -834,7 +835,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
is_pat_syn_match (Generated _) (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat
is_pat_syn_match _ _ = False
non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
- non_wc (Generated _) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
+ non_wc (Generated DoExpansion) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
non_wc _ _ = True
matchEquations :: HsMatchContext GhcRn
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -50,7 +50,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(..))
+import GHC.Types.Basic (Origin(..), isDoExpansionGenerated)
import GHC.Core (CoreExpr)
import GHC.Driver.Session
import GHC.Hs
@@ -142,16 +142,17 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
-- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)
-- each of a 'Match'es 'GRHS' for Note [Long-distance information].
--
--- Special case: When there are /no matches/, then the functionassumes it
+-- Special case: When there are /no matches/, then the function assumes it
-- checks and @-XEmptyCase@ with only a single match variable.
-- See Note [Checking EmptyCase].
pmcMatches
- :: DsMatchContext -- ^ Match context, for warnings messages
+ :: Origin
+ -> DsMatchContext -- ^ Match context, for warnings messages
-> [Id] -- ^ Match variables, i.e. x and y above
-> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches
-> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and
-- GRHS, for long distance info.
-pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
+pmcMatches origin ctxt vars matches = {-# 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!
@@ -175,7 +176,9 @@ pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
result <- {-# SCC "checkMatchGroup" #-}
unCA (checkMatchGroup matches) missing
tracePm "}: " (ppr (cr_uncov result))
- {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
+ when (not (isDoExpansionGenerated origin)) -- Generated code shouldn't generate overlapping warnings
+ ({-# SCC "formatReportWarnings" #-}
+ formatReportWarnings ReportMatchGroup ctxt vars result)
return (NE.toList (ldiMatchGroup (cr_ret result)))
{- Note [pmcPatBind only checks PatBindRhs]
=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -120,8 +120,10 @@ isMatchContextPmChecked dflags origin kind
-- are enabled, in which case we need to run the pattern match checker.
needToRunPmCheck :: DynFlags -> Origin -> Bool
needToRunPmCheck dflags origin
+ | isDoExpansionGenerated origin
+ = False
| isGenerated origin
- = True
+ = True
| otherwise
= notNull (filter (`wopt` dflags) allPmCheckWarnings)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -408,26 +408,24 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-tcExpr (HsDo _ doFlav@(DoExpr{}) (L loc stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts))
- (unLoc expand_expr)
- -- Do expansion on the fly
- ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
- , text "expanded:" <+> ppr expand_expr
- ])
- ; tcExpr expand_do_expr res_ty
+ -- Do expansion on the fly
+ ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
+ ; traceTc "tcDoStmts doExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
+ , text "expanded:" <+> ppr expand_expr
+ ])
+ ; tcExpr expanded_do_expr res_ty
}
-tcExpr (HsDo _ doFlav@(MDoExpr{}) (L loc stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts))
- (unLoc expand_expr)
- -- Do expansion on the fly
- ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
- , text "expanded:" <+> ppr expand_expr
- ])
- ; tcExpr expand_do_expr res_ty
+ -- Do expansion on the fly
+ ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
+ ; traceTc "tcDoStmts mDoExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
+ , text "expanded:" <+> ppr expand_expr
+ ])
+ ; tcExpr expanded_do_expr res_ty
}
tcExpr (HsDo _ do_or_lc stmts) res_ty
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -1644,10 +1644,8 @@ isIrrefutableHsPatRn tc_env is_strict pat =
go (AsPat _ _ _ pat) = goL pat
go (ViewPat _ _ pat) = goL pat
go (SigPat _ pat _) = goL pat
- go (TuplePat _ pats _) =
- do traceTc "isIrrefutableHsPatRn TuplePat" empty
- foldM (\a p -> do {b <- goL p; return (a && b)}) True pats
-
+ go (TuplePat _ pats _) = do bs <- mapM goL pats
+ return (and bs)
go (SumPat {}) = return False
-- See Note [Unboxed sum patterns aren't irrefutable]
go (ListPat {}) = return False
@@ -1656,31 +1654,21 @@ isIrrefutableHsPatRn tc_env is_strict pat =
{ pat_con = L _ dcName
, pat_args = details }) =
do { tyth <- tcLookupGlobal dcName
- ; traceTc "isIrrefutableHsPatRn dataCon" (ppr tyth)
+ ; traceTc "isIrrefutableHsPatRn TyThing" (ppr tyth)
; case tyth of
(ATyCon tycon) ->
- do { b <- foldM (\a p -> do {b <- goL p; return (a && b)}) True (hsConPatArgs details)
- ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon
- , ppr (isNewTyCon tycon)
- , ppr (tcHasFixedRuntimeRep tycon)])
+ do { bs <- mapM goL (hsConPatArgs details)
; let b' = isJust (tyConSingleDataCon_maybe tycon)
- ; return (b && b') }
- id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
+ ; return (b' && and bs) }
(AConLike cl) ->
case cl of
RealDataCon dc ->
do let tycon = dataConTyCon dc
- b <- foldM (\a p -> do {b <- goL p; return (a && b)})
- True (hsConPatArgs details)
- traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon
- , ppr (isNewTyCon tycon)
- , ppr (tcHasFixedRuntimeRep tycon)] )
let b' = isJust (tyConSingleDataCon_maybe tycon)
- return (b && b')
- PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con)
- return False -- conservative
-
- ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
+ bs <- mapM goL (hsConPatArgs details)
+ return (b' && and bs)
+ PatSynCon _pat -> return False -- conservative
+ _ -> pprPanic "isIrrefutableHsPatRn" (ppr tyth)
}
go (LitPat {}) = do traceTc "isIrrefutableHsPatRn LitPat" empty
return False
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -40,7 +40,7 @@ import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.Basic (Activation, RuleName)
import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
import GHC.Parser.Errors.Basic
-import {-# SOURCE #-} Language.Haskell.Syntax.Expr
+import Language.Haskell.Syntax.Expr
import GHC.Unit.Module.Imported (ImportedModsVal)
import GHC.Data.FastString (fsLit)
import Language.Haskell.Syntax (LPat, LIdP)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2672,6 +2672,7 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsProc an _ _) = fromAnn an
getAnnotationEntry (HsStatic an _) = fromAnn an
getAnnotationEntry (HsPragE{}) = NoEntryVal
+ getAnnotationEntry (PopSrcSpan{}) = NoEntryVal
setAnnotationAnchor a@(HsVar{}) _ _s = a
setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)
@@ -2710,6 +2711,7 @@ instance ExactPrint (HsExpr GhcPs) where
setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b)
setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a)
setAnnotationAnchor a@(HsPragE{}) _ _s = a
+ setAnnotationAnchor a@(PopSrcSpan{}) _ _s = a
exact (HsVar x n) = do
n' <- markAnnotated n
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9481110439d9f905521848fccd8a6ba1055d97de
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9481110439d9f905521848fccd8a6ba1055d97de
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230519/537a9eca/attachment-0001.html>
More information about the ghc-commits
mailing list