[Git][ghc/ghc][wip/expand-do] - Discard default monad fail alternatives that are spuriously generated
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri May 5 21:42:40 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
4f8d5755 by Apoorv Ingle at 2023-05-05T16:42:27-05:00
- Discard default monad fail alternatives that are spuriously generated
- Make sure we check for generated loc span for checking if the (>>) is user written or expanded for /do/ purposes
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1114,9 +1114,9 @@ data HsExpansion orig expanded
-- | Just print the original expression (the @a@) with the expanded version (the @b@)
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
- -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
- -- (ppr orig)
- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
+ = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ (ppr orig)
+ -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
{-
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.Hs.Pat (
mkPrefixConPat, mkCharLitPat, mkNilPat,
- isSimplePat,
+ isSimplePat, isPatSyn,
looksLazyPatBind,
isBangedLPat,
gParPat, patNeedsParens, parenthesizePat,
@@ -617,6 +617,10 @@ isSimplePat p = case unLoc p of
VarPat _ x -> Just (unLoc x)
_ -> Nothing
+isPatSyn :: LPat GhcTc -> Bool
+isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True
+isPatSyn _ = False
+
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -858,31 +858,27 @@ warnDiscardedDoBindings rhs rhs_ty
warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
warnUnusedBindValue fun arg arg_ty
- | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun
- , is_gen_then f
- -- , isNoSrcSpan l
+ | Just (l, f) <- fish_var fun
+ , f `hasKey` thenMClassOpKey -- it is a (>>)
+ , isGeneratedSrcSpan l -- it is compiler generated
= do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
- , text "arg" <+> ppr arg
- , text "arg_ty" <+> ppr arg_ty
- , text "f" <+> ppr f <+> ppr (is_gen_then f)
- , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc)
+ , text "loc" <+> ppr l
+ , text "locGen?" <+> ppr (isGeneratedSrcSpan l)
+ , text "noLoc?" <+> ppr (isNoSrcSpan l)
])
warnDiscardedDoBindings arg arg_ty
where
-- retrieve the location info and the head of the application
- fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc)
- fish_var (L l (HsVar _ id)) = return (l, id)
- fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e)
+ -- It is important that we /do not/ look through HsApp to avoid
+ -- generating duplicate warnings
+ fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
+ fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
fish_var (L _ (HsAppType _ e _ _)) = fish_var e
fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
return (l, e')
fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e)
fish_var _ = Nothing
- -- is this id a compiler generated (>>) with expanded do
- is_gen_then :: Id -> Bool
- is_gen_then f = f `hasKey` thenMClassOpKey
-
warnUnusedBindValue _ _ _ = return ()
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -227,7 +227,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty
match_groups [] = matchEmpty v ty
match_groups (g:gs) = mapM match_group $ g :| gs
- match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
+ match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr)
match_group eqns@((group,_) :| _)
= case group of
PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
@@ -767,12 +767,15 @@ 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_wc origin) matches' -- filter out the wild pattern fail alternatives that
+ -- generate spurious overlapping warnings
+ else matches'
; new_vars <- case matches of
[] -> newSysLocalsDs arg_tys
(m:_) ->
@@ -827,7 +830,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
$ NEL.nonEmpty
$ replicate (length (grhssGRHSs m)) initNablas
-
+ is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
+ 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 _ _ = True
+
matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -91,7 +91,7 @@ import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
+import GHC.Types.Basic ( Origin (..) )
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.Var (EvId)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -325,7 +325,9 @@ tcApp rn_expr exp_res_ty
| (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
= do { traceTc "tcApp {" $
vcat [ text "rn_fun:" <+> ppr rn_fun
- , text "rn_args:" <+> ppr rn_args ]
+ , text "rn_args:" <+> ppr rn_args
+ , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt)
+ ]
; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1383,17 +1383,16 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc
mk_failable_lexpr_tcm pat lexpr fail_op =
do { tc_env <- getGblEnv
; is_strict <- xoptM LangExt.Strict
- ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat
+ ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat
, ppr $ isIrrefutableHsPatRn tc_env is_strict pat
])
; if isIrrefutableHsPatRn tc_env is_strict pat
- -- don't decorate with fail statement if the pattern is irrefutable
- -- pattern syns always get a fail block while desugaring so skip
+ -- don't decorate with fail statement if
+ -- 1) the pattern is irrefutable
then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
else mk_fail_lexpr pat lexpr fail_op
}
- where
-- makes the fail block
-- TODO: check the discussion around MonadFail.fail type signature.
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -1623,9 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case
has_existentials :: Bool
has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
-
+-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the
isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool
-isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat
+isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL
where
goL :: LPat GhcRn -> Bool
goL = go . unLoc
@@ -1649,11 +1649,22 @@ isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat =
go (ConPat
{ pat_con = L _ dcName
- , pat_args = details }) = case lookupTypeEnv type_env dcName of
- Just (ATyCon con) ->
- isJust (tyConSingleDataCon_maybe con)
- && all goL (hsConPatArgs details)
- _ -> False -- conservative.
+ , pat_args = details }) =
+ case lookupTypeEnv type_env dcName of
+ Just (ATyCon tycon) ->
+ (isJust (tyConSingleDataCon_maybe tycon)
+ || isNewTyCon tycon)
+ && all goL (hsConPatArgs details)
+ Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
+ Just (AConLike cl) -> case cl of
+ RealDataCon dc -> let tycon = dataConTyCon dc in
+ (isJust (tyConSingleDataCon_maybe tycon)
+ || isNewTyCon tycon)
+ && all goL (hsConPatArgs details)
+ PatSynCon _ -> False -- conservative
+
+ Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
+ _ -> False -- conservative.
go (LitPat {}) = False
go (NPat {}) = False
go (NPlusKPat {}) = False
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f8d57550995e70a60bf7d7972cd4a65190dbdec
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f8d57550995e70a60bf7d7972cd4a65190dbdec
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/20230505/a7155a5b/attachment-0001.html>
More information about the ghc-commits
mailing list