diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-08-12 18:35:28 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-10 10:35:33 -0400 |
commit | 67ce72da1689058cb689ffbb6fcbd5cd12af56df (patch) | |
tree | 694ee73ed29fc5953b1cc2f57c72f0761c8ad5dc /compiler/GHC | |
parent | 4798caa0fefd7adf4c5b85fa84a6f28fcc6b350b (diff) | |
download | haskell-67ce72da1689058cb689ffbb6fcbd5cd12af56df.tar.gz |
Add long-distance info for pattern bindings (#18572)
We didn't consider the RHS of a pattern-binding before, which led to
surprising warnings listed in #18572.
As can be seen from the regression test T18572, we get the expected
output now.
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/HsToCore/Binds.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/GuardedRHSs.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/ListComp.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match.hs | 45 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match.hs-boot | 1 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/PmCheck.hs | 75 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/PmCheck/Oracle.hs | 2 |
8 files changed, 77 insertions, 70 deletions
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index c8b4087958..f900d45c55 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -33,7 +33,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) import GHC.HsToCore.Monad import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils -import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs ) +import GHC.HsToCore.PmCheck ( addTyCsDs, covCheckGRHSs ) import GHC.Hs -- lots of things import GHC.Core -- lots of things @@ -185,7 +185,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss , pat_ext = ty , pat_ticks = (rhs_tick, var_ticks) }) - = do { rhss_deltas <- checkGRHSs PatBindGuards grhss + = do { rhss_deltas <- covCheckGRHSs PatBindGuards grhss ; body_expr <- dsGuarded grhss ty rhss_deltas ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 732f86cbdf..659f8da7e7 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -31,7 +31,7 @@ import GHC.HsToCore.ListComp import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad -import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs ) +import GHC.HsToCore.PmCheck ( addTyCsDs, covCheckGRHSs ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) @@ -215,7 +215,7 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss , pat_ext = ty }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body - do { match_deltas <- checkGRHSs PatBindGuards grhss + do { match_deltas <- covCheckGRHSs PatBindGuards grhss ; rhs <- dsGuarded grhss ty match_deltas ; let upat = unLoc pat eqn = EqnInfo { eqn_pats = [upat], @@ -486,7 +486,7 @@ dsExpr (HsMultiIf res_ty alts) | otherwise = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds) - ; rhss_deltas <- checkGRHSs IfAlt grhss + ; rhss_deltas <- covCheckGRHSs IfAlt grhss ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_deltas ; error_expr <- mkErrorExpr ; extractMatchResult match_result error_expr } @@ -981,7 +981,7 @@ dsDo ctx stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat - ; match <- matchSinglePatVar var (StmtCtxt ctx) pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat (xbstc_boundResultType xbs) (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } @@ -1002,7 +1002,7 @@ dsDo ctx stmts ; let match_args (pat, fail_op) (vs,body) = do { var <- selectSimpleMatchVarL Many pat - ; match <- matchSinglePatVar var (StmtCtxt ctx) pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match fail_op ; return (var:vs, match_code) diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 6ff171febc..55ede1ddcb 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -36,7 +36,7 @@ import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList ) {- -@dsGuarded@ is used for pattern bindings. +@dsGuarded@ is used for GRHSs. It desugars: \begin{verbatim} | g1 -> e1 @@ -44,7 +44,7 @@ It desugars: | gn -> en where binds \end{verbatim} -producing an expression with a runtime error in the corner if +producing an expression with a runtime error in the corner case if necessary. The type argument gives the type of the @ei@. -} @@ -137,8 +137,8 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx deltas rhs rhs_ty = do match_result <- matchGuards stmts ctx deltas rhs rhs_ty core_rhs <- dsLExpr bind_rhs - match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty - match_result + match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx) + pat rhs_ty match_result pure $ bindNonRec match_var core_rhs <$> match_result' matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt" diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 0ecff073fc..19d46c1f2f 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -617,7 +617,7 @@ dsMcBindStmt :: LPat GhcTc dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts ; var <- selectSimpleMatchVarL Many pat - ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat res1_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 98a27c97f3..75717c4bd9 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -66,7 +66,7 @@ import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM -import Control.Monad(zipWithM, unless ) +import Control.Monad ( zipWithM, unless, when ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map @@ -769,9 +769,9 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches -- @rhss_deltas@ is a flat list of covered Deltas for each RHS. -- Each Match will split off one Deltas for its RHSs from this. ; matches_deltas <- if isMatchContextPmChecked dflags origin ctxt - then addScrutTmCs mb_scr new_vars $ + then addHsScrutTmCs mb_scr new_vars $ -- See Note [Type and Term Equality Propagation] - checkMatches (DsMatchContext ctxt locn) new_vars matches + covCheckMatchGroup (DsMatchContext ctxt locn) new_vars matches else pure (initDeltasMatches matches) ; eqns_info <- zipWithM mk_eqn_info matches matches_deltas @@ -820,25 +820,24 @@ matchEquations ctxt vars eqns_info rhs_ty ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } -{- -************************************************************************ -* * -\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -* * -************************************************************************ - -@mkSimpleMatch@ is a wrapper for @match@ which deals with the -situation where we want to match a single expression against a single -pattern. It returns an expression. --} - +-- | @matchSimply@ is a wrapper for 'match' which deals with the +-- situation where we want to match a single expression against a single +-- pattern. It returns an expression. matchSimply :: CoreExpr -- ^ Scrutinee -> HsMatchContext GhcRn -- ^ Match kind -> LPat GhcTc -- ^ Pattern it should match -> CoreExpr -- ^ Return this if it matches -> CoreExpr -- ^ Return this if it doesn't -> DsM CoreExpr --- Do not warn about incomplete patterns; see matchSinglePat comments +-- Some reasons 'matchSimply' is not defined using 'matchWrapper' (#18572): +-- * Some call sites like in 'deBindComp' specify a @fail_expr@ that isn't a +-- straight @patError@ +-- * It receives an already desugared 'CoreExpr' for the scrutinee, not an +-- 'HsExpr' like 'matchWrapper' expects +-- * Filling in all the phony fields for the 'MatchGroup' for a single pattern +-- match is awkward +-- * And we still export 'matchSinglePatVar', so not much is gained if we +-- don't also implement it in terms of 'matchWrapper' matchSimply scrut hs_ctx pat result_expr fail_expr = do let match_result = cantFailMatchResult result_expr @@ -858,7 +857,7 @@ matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc matchSinglePat (Var var) ctx pat ty match_result | not (isExternalName (idName var)) - = matchSinglePatVar var ctx pat ty match_result + = matchSinglePatVar var Nothing ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result = do { var <- selectSimpleMatchVarL Many pat @@ -867,22 +866,22 @@ matchSinglePat scrut hs_ctx pat ty match_result -- and to create field selectors. All of which only -- bind unrestricted variables, hence the 'Many' -- above. - ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result + ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result ; return $ bindNonRec var scrut <$> match_result' } matchSinglePatVar :: Id -- See Note [Match Ids] + -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -matchSinglePatVar var ctx pat ty match_result +matchSinglePatVar var mb_scrut ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) do { dflags <- getDynFlags ; locn <- getSrcSpanDs - -- Pattern match check warnings - ; if isMatchContextPmChecked dflags FromSource ctx - then checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) - else pure () + ; when (isMatchContextPmChecked dflags FromSource ctx) $ + addCoreScrutTmCs mb_scrut [var] $ + covCheckPatBind dflags (DsMatchContext ctx locn) var (unLoc pat) ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] , eqn_orig = FromSource diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index b42c84e10a..3014c069a5 100644 --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -29,6 +29,7 @@ matchSimply matchSinglePatVar :: Id + -> Maybe CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc -> Type diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 31ac10f0a0..6ba760369b 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -14,11 +14,11 @@ Pattern Matching Coverage Checking. module GHC.HsToCore.PmCheck ( -- Checking and printing - checkSingle, checkMatches, checkGRHSs, + covCheckPatBind, covCheckMatchGroup, covCheckGRHSs, isMatchContextPmChecked, -- See Note [Type and Term Equality Propagation] - addTyCsDs, addScrutTmCs + addTyCsDs, addCoreScrutTmCs, addHsScrutTmCs ) where #include "HsVersions.h" @@ -283,37 +283,38 @@ instance Outputable CheckResult where {- %************************************************************************ %* * - Entry points to the checker: checkSingle and checkMatches + Entry points to the checker: covCheckPatBind and covCheckMatchGroup %* * %************************************************************************ -} --- | Check a single pattern binding (let) for exhaustiveness. -checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM () -checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do - tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) +-- | Check a pattern binding (let, where) for exhaustiveness. +covCheckPatBind :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM () +covCheckPatBind dflags ctxt@(DsMatchContext _ locn) var p = do -- We only ever need to run this in a context where we need exhaustivity -- warnings (so not in pattern guards or comprehensions, for example, because -- they are perfectly fine to fail). -- Omitting checking this flag emits redundancy warnings twice in obscure -- cases like #17646. - when (exhaustive dflags kind) $ do - -- TODO: This could probably call checkMatches, like checkGRHSs. - missing <- getPmDeltas - tracePm "checkSingle: missing" (ppr missing) - fam_insts <- dsGetFamInstEnvs - grd_tree <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p - res <- checkGrdTree grd_tree missing - dsPmWarn dflags ctxt [var] res + -- Given the context in which this function is called, it will only ever do + -- something for + -- * PatBindRhs, -Wincomplete-uni-patterns: @let True = False@ + -- * PatBindGuards, -Wincomplete-patterns: @Just x | False = Just 42@ + missing <- getPmDeltas + tracePm "covCheckPatBind" (vcat [ppr ctxt, ppr var, ppr p, ppr missing]) + fam_insts <- dsGetFamInstEnvs + grd_tree <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p + res <- checkGrdTree grd_tree missing + dsPmWarn dflags ctxt [var] res -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. Returns the 'Deltas' covered by the RHSs. -checkGRHSs +covCheckGRHSs :: HsMatchContext GhcRn -- ^ Match context, for warning messages -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check -> DsM (NonEmpty Deltas) -- ^ Covered 'Deltas' for each RHS, for long -- distance info -checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do +covCheckGRHSs hs_ctx guards@(GRHSs _ grhss _) = do let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc match = L combinedLoc $ @@ -321,7 +322,7 @@ checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do , m_ctxt = hs_ctx , m_pats = [] , m_grhss = guards } - [(_, deltas)] <- checkMatches dsMatchContext [] [match] + [(_, deltas)] <- covCheckMatchGroup dsMatchContext [] [match] pure deltas -- | Check a list of syntactic /match/es (part of case, functions, etc.), each @@ -337,14 +338,14 @@ checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do -- incoming uncovered 'Deltas' (from 'getPmDeltas') if the GRHS is inaccessible. -- Since there is at least one /grhs/ per /match/, the list of 'Deltas' is at -- least as long as the list of matches. -checkMatches +covCheckMatchGroup :: DsMatchContext -- ^ Match context, for warnings messages -> [Id] -- ^ Match variables, i.e. x and y above -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches -> DsM [(Deltas, NonEmpty Deltas)] -- ^ One covered 'Deltas' per RHS, for long -- distance info. -checkMatches ctxt vars matches = do - tracePm "checkMatches" (hang (vcat [ppr ctxt +covCheckMatchGroup ctxt vars matches = do + tracePm "covCheckMatchGroup" (hang (vcat [ppr ctxt , ppr vars , text "Matches:"]) 2 @@ -1112,7 +1113,7 @@ f x = case x of (_:_) -> True [] -> False -- can't happen -Functions `addScrutTmCs' is responsible for generating +Functions `add*ScrutTmCs' is responsible for generating these constraints. -} @@ -1141,17 +1142,24 @@ addTyCsDs origin ev_vars m = do (locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars))) m --- | Add equalities for the scrutinee to the local 'DsM' environment when --- checking a case expression: +-- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment +-- 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. -addScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a -addScrutTmCs Nothing _ k = k -addScrutTmCs (Just scr) [x] k = do +addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a +addCoreScrutTmCs Nothing _ k = k +addCoreScrutTmCs (Just scr) [x] k = + flip locallyExtendPmDelta k $ \deltas -> + addPmCtsDeltas deltas (unitBag (PmCoreCt 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 - locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (unitBag (PmCoreCt x scr_e))) k -addScrutTmCs _ _ _ = panic "addScrutTmCs: HsCase with more than one case binder" + addCoreScrutTmCs (Just scr_e) vars k {- %************************************************************************ @@ -1169,7 +1177,7 @@ isMatchContextPmChecked dflags origin kind | isGenerated origin = False | otherwise - = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind + = overlapping dflags kind || exhaustive dflags kind -- | Return True when any of the pattern match warnings ('allPmCheckWarnings') -- are enabled, in which case we need to run the pattern match checker. @@ -1399,10 +1407,9 @@ exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd exhaustiveWarningFlag ThPatSplice = Nothing exhaustiveWarningFlag PatSyn = Nothing exhaustiveWarningFlag ThPatQuote = Nothing -exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns - -- in list comprehensions, pattern guards - -- etc. They are often *supposed* to be - -- incomplete +-- Don't warn about incomplete patterns in list comprehensions, pattern guards +-- etc. They are often *supposed* to be incomplete +exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- True <==> singular pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index 04bff18be1..f607231d18 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -1266,7 +1266,7 @@ isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons {- Note [Checking EmptyCase Expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Empty case expressions are strict on the scrutinee. That is, `case x of {}` -will force argument `x`. Hence, `checkMatches` is not sufficient for checking +will force argument `x`. Hence, `covCheckMatchGroup` is not sufficient for checking empty cases, because it assumes that the match is not strict (which is true for all other cases, apart from EmptyCase). This gave rise to #10746. Instead, we do the following: |