{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
module GHC.HsToCore.Pmc (
pmcPatBind, pmcMatches, pmcGRHSs, pmcRecSel,
isMatchContextPmChecked, isMatchContextPmChecked_SinglePat,
addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas,
getNFirstUncovered
) where
import GHC.Prelude
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Pmc.Types
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.Core
import GHC.Driver.DynFlags
import GHC.Hs
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.Var (EvVar, Var (..))
import GHC.Types.Id.Info
import GHC.Tc.Utils.TcType (evVarPred)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
import GHC.HsToCore.Monad
import GHC.Data.Bag
import GHC.Data.OrdList
import Control.Monad (when, unless, forM_)
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Coerce
import GHC.Tc.Utils.Monad
getLdiNablas :: DsM Nablas
getLdiNablas :: DsM Nablas
getLdiNablas = do
nablas <- DsM Nablas
getPmNablas
isInhabited nablas >>= \case
Bool
True -> Nablas -> DsM Nablas
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nablas
nablas
Bool
False -> Nablas -> DsM Nablas
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nablas
initNablas
noCheckDs :: DsM a -> DsM a
noCheckDs :: forall a. DsM a -> DsM a
noCheckDs = (DynFlags -> DynFlags)
-> TcRnIf DsGblEnv DsLclEnv a -> TcRnIf DsGblEnv DsLclEnv a
forall gbl lcl a.
(DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags (\DynFlags
dflags -> (DynFlags -> WarningFlag -> DynFlags)
-> DynFlags -> [WarningFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> WarningFlag -> DynFlags
wopt_unset DynFlags
dflags [WarningFlag]
allPmCheckWarnings)
pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM Nablas
pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM Nablas
pmcPatBind ctxt :: DsMatchContext
ctxt@(DsMatchContext HsMatchContextRn
match_ctxt SrcSpan
loc) Id
var Pat GhcTc
p
= DsM Nablas -> DsM Nablas
mb_discard_warnings (DsM Nablas -> DsM Nablas) -> DsM Nablas -> DsM Nablas
forall a b. (a -> b) -> a -> b
$ do
!missing <- DsM Nablas
getLdiNablas
pat_bind <- noCheckDs $ desugarPatBind loc var p
tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])
result <- unCA (checkPatBind pat_bind) missing
let ldi = PmGRHS Post -> Nablas
ldiGRHS (PmGRHS Post -> Nablas) -> PmGRHS Post -> Nablas
forall a b. (a -> b) -> a -> b
$ ( \ PmPatBind Post
pb -> case PmPatBind Post
pb of PmPatBind PmGRHS Post
grhs -> PmGRHS Post
grhs) (PmPatBind Post -> PmGRHS Post) -> PmPatBind Post -> PmGRHS Post
forall a b. (a -> b) -> a -> b
$ CheckResult (PmPatBind Post) -> PmPatBind Post
forall a. CheckResult a -> a
cr_ret CheckResult (PmPatBind Post)
result
tracePm "pmcPatBind }: " $
vcat [ text "cr_uncov:" <+> ppr (cr_uncov result)
, text "ldi:" <+> ppr ldi ]
formatReportWarnings ReportPatBind ctxt [var] result
return ldi
where
mb_discard_warnings :: DsM Nablas -> DsM Nablas
mb_discard_warnings
= if HsMatchContext (GenLocated SrcSpanAnnN Name) -> Bool
forall {fn}. HsMatchContext fn -> Bool
want_pmc HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
match_ctxt
then DsM Nablas -> DsM Nablas
forall a. a -> a
id
else DsM Nablas -> DsM Nablas
forall a. DsM a -> DsM a
discardWarningsDs
want_pmc :: HsMatchContext fn -> Bool
want_pmc HsMatchContext fn
PatBindRhs = Bool
True
want_pmc HsMatchContext fn
LazyPatCtx = Bool
True
want_pmc (StmtCtxt HsStmtContext fn
stmt_ctxt) =
case HsStmtContext fn
stmt_ctxt of
PatGuard {} -> Bool
False
HsStmtContext fn
_ -> Bool
True
want_pmc HsMatchContext fn
_ = Bool
False
pmcGRHSs
:: HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc)
-> DsM (NonEmpty Nablas)
pmcGRHSs :: HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContextRn
hs_ctxt guards :: GRHSs GhcTc (LHsExpr GhcTc)
guards@(GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
_ [LGRHS GhcTc (LHsExpr GhcTc)]
grhss HsLocalBinds GhcTc
_) = do
let combined_loc :: SrcSpan
combined_loc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SrcSpan)
-> [GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
grhss)
ctxt :: DsMatchContext
ctxt = HsMatchContextRn -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContextRn
hs_ctxt SrcSpan
combined_loc
!missing <- DsM Nablas
getLdiNablas
matches <- noCheckDs $ desugarGRHSs combined_loc empty guards
tracePm "pmcGRHSs" (hang (vcat [ppr ctxt
, text "Guards:"])
2
(pprGRHSs hs_ctxt guards $$ ppr missing))
result <- unCA (checkGRHSs matches) missing
tracePm "}: " (ppr (cr_uncov result))
formatReportWarnings ReportGRHSs ctxt [] result
return (ldiGRHSs (cr_ret result))
pmcMatches
:: Origin
-> DsMatchContext
-> [Id]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> DsM [(Nablas, NonEmpty Nablas)]
pmcMatches :: Origin
-> DsMatchContext
-> [Id]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> DsM [(Nablas, NonEmpty Nablas)]
pmcMatches Origin
origin DsMatchContext
ctxt [Id]
vars [LMatch GhcTc (LHsExpr GhcTc)]
matches = {-# SCC "pmcMatches" #-} do
!missing <- DsM Nablas
getLdiNablas
tracePm "pmcMatches {" $
hang (vcat [ppr origin, ppr ctxt, ppr vars, text "Matches:"])
2
((ppr matches) $$ (text "missing:" <+> ppr missing))
case NE.nonEmpty matches of
Maybe
(NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
Nothing -> do
let var :: Id
var = [Id] -> Id
forall a. [a] -> a
only [Id]
vars
empty_case <- DsM PmEmptyCase -> DsM PmEmptyCase
forall a. DsM a -> DsM a
noCheckDs (DsM PmEmptyCase -> DsM PmEmptyCase)
-> DsM PmEmptyCase -> DsM PmEmptyCase
forall a b. (a -> b) -> a -> b
$ Id -> DsM PmEmptyCase
desugarEmptyCase Id
var
result <- unCA (checkEmptyCase empty_case) missing
tracePm "}: " (ppr (cr_uncov result))
formatReportWarnings ReportEmptyCase ctxt vars result
return []
Just NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
matches -> do
matches <- {-# SCC "desugarMatches" #-}
DsM (PmMatchGroup Pre) -> DsM (PmMatchGroup Pre)
forall a. DsM a -> DsM a
noCheckDs (DsM (PmMatchGroup Pre) -> DsM (PmMatchGroup Pre))
-> DsM (PmMatchGroup Pre) -> DsM (PmMatchGroup Pre)
forall a b. (a -> b) -> a -> b
$ [Id]
-> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
-> DsM (PmMatchGroup Pre)
desugarMatches [Id]
vars NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
matches
tracePm "desugared matches" (ppr matches)
result <- {-# SCC "checkMatchGroup" #-}
unCA (checkMatchGroup matches) missing
tracePm "}: " (ppr (cr_uncov result))
unless (isDoExpansionGenerated origin)
({-# SCC "formatReportWarnings" #-}
formatReportWarnings ReportMatchGroup ctxt vars result)
return (NE.toList (ldiMatchGroup (cr_ret result)))
pmcRecSel :: Id
-> CoreExpr
-> DsM ()
pmcRecSel :: Id -> CoreExpr -> DsM ()
pmcRecSel Id
sel_id CoreExpr
arg
| RecSelId{ sel_cons :: IdDetails -> RecSelInfo
sel_cons = RecSelInfo
rec_sel_info } <- Id -> IdDetails
idDetails Id
sel_id
, RSI { rsi_def :: RecSelInfo -> [ConLike]
rsi_def = [ConLike]
cons_w_field, rsi_undef :: RecSelInfo -> [ConLike]
rsi_undef = [ConLike]
cons_wo_field } <- RecSelInfo
rec_sel_info
, Bool -> Bool
not ([ConLike] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
cons_wo_field)
= do { !missing <- DsM Nablas
getLdiNablas
; tracePm "pmcRecSel {" (ppr sel_id)
; CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }
<- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing
; tracePm "}: " $ ppr uncov_nablas
; inhabited <- isInhabited uncov_nablas
; when inhabited $ warn_incomplete arg_id uncov_nablas }
| Bool
otherwise
= () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
sel_name :: Name
sel_name = Id -> Name
varName Id
sel_id
warn_incomplete :: Id -> Nablas -> DsM ()
warn_incomplete Id
arg_id Nablas
uncov_nablas = do
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let maxPatterns = DynFlags -> Int
maxUncoveredPatterns DynFlags
dflags
unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxPatterns + 1) uncov_nablas
let cons = [ConLike
con | Nabla
unc_example <- [Nabla]
unc_examples
, Just (PACA (PmAltConLike ConLike
con) [Id]
_ [Id]
_) <- [Nabla -> Id -> Maybe PmAltConApp
lookupSolution Nabla
unc_example Id
arg_id]]
tracePm "unc-ex" (ppr cons $$ ppr unc_examples)
diagnosticDs $ DsIncompleteRecordSelector sel_name cons maxPatterns
ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
ldiMatchGroup (PmMatchGroup NonEmpty (PmMatch Post)
matches) = PmMatch Post -> (Nablas, NonEmpty Nablas)
ldiMatch (PmMatch Post -> (Nablas, NonEmpty Nablas))
-> NonEmpty (PmMatch Post) -> NonEmpty (Nablas, NonEmpty Nablas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (PmMatch Post)
matches
ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)
ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)
ldiMatch (PmMatch { pm_pats :: forall p. PmMatch p -> p
pm_pats = Post
red, pm_grhss :: forall p. PmMatch p -> PmGRHSs p
pm_grhss = PmGRHSs Post
grhss }) =
(Post -> Nablas
rs_cov Post
red, PmGRHSs Post -> NonEmpty Nablas
ldiGRHSs PmGRHSs Post
grhss)
ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas
ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas
ldiGRHSs (PmGRHSs { pgs_grhss :: forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
pgs_grhss = NonEmpty (PmGRHS Post)
grhss }) = PmGRHS Post -> Nablas
ldiGRHS (PmGRHS Post -> Nablas)
-> NonEmpty (PmGRHS Post) -> NonEmpty Nablas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (PmGRHS Post)
grhss
ldiGRHS :: PmGRHS Post -> Nablas
ldiGRHS :: PmGRHS Post -> Nablas
ldiGRHS (PmGRHS { pg_grds :: forall p. PmGRHS p -> p
pg_grds = Post
red }) = Post -> Nablas
rs_cov Post
red
data CIRB
= CIRB
{ CIRB -> OrdList SrcInfo
cirb_cov :: !(OrdList SrcInfo)
, CIRB -> OrdList SrcInfo
cirb_inacc :: !(OrdList SrcInfo)
, CIRB -> OrdList SrcInfo
cirb_red :: !(OrdList SrcInfo)
, CIRB -> OrdList SrcInfo
cirb_bangs :: !(OrdList SrcInfo)
}
instance Semigroup CIRB where
CIRB OrdList SrcInfo
a OrdList SrcInfo
b OrdList SrcInfo
c OrdList SrcInfo
d <> :: CIRB -> CIRB -> CIRB
<> CIRB OrdList SrcInfo
e OrdList SrcInfo
f OrdList SrcInfo
g OrdList SrcInfo
h = OrdList SrcInfo
-> OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo -> CIRB
CIRB (OrdList SrcInfo
a OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
<> OrdList SrcInfo
e) (OrdList SrcInfo
b OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
<> OrdList SrcInfo
f) (OrdList SrcInfo
c OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
<> OrdList SrcInfo
g) (OrdList SrcInfo
d OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
<> OrdList SrcInfo
h)
where <> :: OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
(<>) = OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
forall a. Semigroup a => a -> a -> a
(Semi.<>)
instance Monoid CIRB where
mempty :: CIRB
mempty = OrdList SrcInfo
-> OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo -> CIRB
CIRB OrdList SrcInfo
forall a. Monoid a => a
mempty OrdList SrcInfo
forall a. Monoid a => a
mempty OrdList SrcInfo
forall a. Monoid a => a
mempty OrdList SrcInfo
forall a. Monoid a => a
mempty
ensureOneNotRedundant :: CIRB -> CIRB
ensureOneNotRedundant :: CIRB -> CIRB
ensureOneNotRedundant CIRB
ci = case CIRB
ci of
CIRB { cirb_cov :: CIRB -> OrdList SrcInfo
cirb_cov = OrdList SrcInfo
NilOL, cirb_inacc :: CIRB -> OrdList SrcInfo
cirb_inacc = OrdList SrcInfo
NilOL, cirb_red :: CIRB -> OrdList SrcInfo
cirb_red = ConsOL SrcInfo
r OrdList SrcInfo
rs }
-> CIRB
ci { cirb_inacc = unitOL r, cirb_red = rs }
CIRB
_ -> CIRB
ci
addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB
addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB
addRedundantBangs OrdList SrcInfo
_red_bangs cirb :: CIRB
cirb@CIRB { cirb_cov :: CIRB -> OrdList SrcInfo
cirb_cov = OrdList SrcInfo
NilOL, cirb_inacc :: CIRB -> OrdList SrcInfo
cirb_inacc = OrdList SrcInfo
NilOL } =
CIRB
cirb
addRedundantBangs OrdList SrcInfo
red_bangs CIRB
cirb =
CIRB
cirb { cirb_bangs = cirb_bangs cirb Semi.<> red_bangs }
testRedSets :: RedSets -> DsM (Bool, Bool, OrdList SrcInfo)
testRedSets :: Post -> DsM (Bool, Bool, OrdList SrcInfo)
testRedSets RedSets { rs_cov :: Post -> Nablas
rs_cov = Nablas
cov, rs_div :: Post -> Nablas
rs_div = Nablas
div, rs_bangs :: Post -> OrdList (Nablas, SrcInfo)
rs_bangs = OrdList (Nablas, SrcInfo)
bangs } = do
is_covered <- Nablas -> DsM Bool
isInhabited Nablas
cov
may_diverge <- isInhabited div
red_bangs <- flip mapMaybeM (fromOL bangs) $ \(Nablas
nablas, SrcInfo
bang) ->
Nablas -> DsM Bool
isInhabited Nablas
nablas DsM Bool
-> (Bool -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo)
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) a
-> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe SrcInfo -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SrcInfo
forall a. Maybe a
Nothing
Bool
False -> Maybe SrcInfo -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcInfo -> Maybe SrcInfo
forall a. a -> Maybe a
Just SrcInfo
bang)
pure (is_covered, may_diverge, toOL red_bangs)
cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB
cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB
cirbsMatchGroup (PmMatchGroup NonEmpty (PmMatch Post)
matches) =
NonEmpty CIRB -> CIRB
forall a. Semigroup a => NonEmpty a -> a
Semi.sconcat (NonEmpty CIRB -> CIRB)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB) -> DsM CIRB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PmMatch Post -> DsM CIRB)
-> NonEmpty (PmMatch Post)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse PmMatch Post -> DsM CIRB
cirbsMatch NonEmpty (PmMatch Post)
matches
cirbsMatch :: PmMatch Post -> DsM CIRB
cirbsMatch :: PmMatch Post -> DsM CIRB
cirbsMatch PmMatch { pm_pats :: forall p. PmMatch p -> p
pm_pats = Post
red, pm_grhss :: forall p. PmMatch p -> PmGRHSs p
pm_grhss = PmGRHSs Post
grhss } = do
(_is_covered, may_diverge, red_bangs) <- Post -> DsM (Bool, Bool, OrdList SrcInfo)
testRedSets Post
red
cirb <- cirbsGRHSs grhss
pure $ addRedundantBangs red_bangs
$ applyWhen may_diverge ensureOneNotRedundant
$ cirb
cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
cirbsGRHSs (PmGRHSs { pgs_grhss :: forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
pgs_grhss = NonEmpty (PmGRHS Post)
grhss }) = NonEmpty CIRB -> CIRB
forall a. Semigroup a => NonEmpty a -> a
Semi.sconcat (NonEmpty CIRB -> CIRB)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB) -> DsM CIRB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PmGRHS Post -> DsM CIRB)
-> NonEmpty (PmGRHS Post)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse PmGRHS Post -> DsM CIRB
cirbsGRHS NonEmpty (PmGRHS Post)
grhss
cirbsGRHS :: PmGRHS Post -> DsM CIRB
cirbsGRHS :: PmGRHS Post -> DsM CIRB
cirbsGRHS PmGRHS { pg_grds :: forall p. PmGRHS p -> p
pg_grds = Post
red, pg_rhs :: forall p. PmGRHS p -> SrcInfo
pg_rhs = SrcInfo
info } = do
(is_covered, may_diverge, red_bangs) <- Post -> DsM (Bool, Bool, OrdList SrcInfo)
testRedSets Post
red
let cirb | Bool
is_covered = CIRB
forall a. Monoid a => a
mempty { cirb_cov = unitOL info }
| Bool
may_diverge = CIRB
forall a. Monoid a => a
mempty { cirb_inacc = unitOL info }
| Bool
otherwise = CIRB
forall a. Monoid a => a
mempty { cirb_red = unitOL info }
pure (addRedundantBangs red_bangs cirb)
cirbsEmptyCase :: PmEmptyCase -> DsM CIRB
cirbsEmptyCase :: PmEmptyCase -> DsM CIRB
cirbsEmptyCase PmEmptyCase
_ = CIRB -> DsM CIRB
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CIRB
forall a. Monoid a => a
mempty
cirbsPatBind :: PmPatBind Post -> DsM CIRB
cirbsPatBind :: PmPatBind Post -> DsM CIRB
cirbsPatBind = (PmGRHS Post -> DsM CIRB) -> PmPatBind Post -> DsM CIRB
forall a b. Coercible a b => a -> b
coerce PmGRHS Post -> DsM CIRB
cirbsGRHS
data FormatReportWarningsMode ann where
ReportPatBind :: FormatReportWarningsMode (PmPatBind Post)
ReportGRHSs :: FormatReportWarningsMode (PmGRHSs Post)
ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post)
ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase
deriving instance Eq (FormatReportWarningsMode ann)
collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB
collectInMode :: forall ann. FormatReportWarningsMode ann -> ann -> DsM CIRB
collectInMode FormatReportWarningsMode ann
ReportPatBind = ann -> DsM CIRB
PmPatBind Post -> DsM CIRB
cirbsPatBind
collectInMode FormatReportWarningsMode ann
ReportGRHSs = ann -> DsM CIRB
PmGRHSs Post -> DsM CIRB
cirbsGRHSs
collectInMode FormatReportWarningsMode ann
ReportMatchGroup = ann -> DsM CIRB
PmMatchGroup Post -> DsM CIRB
cirbsMatchGroup
collectInMode FormatReportWarningsMode ann
ReportEmptyCase = ann -> DsM CIRB
PmEmptyCase -> DsM CIRB
cirbsEmptyCase
formatReportWarnings :: FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings :: forall ann.
FormatReportWarningsMode ann
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings FormatReportWarningsMode ann
report_mode DsMatchContext
ctx [Id]
vars cr :: CheckResult ann
cr@CheckResult { cr_ret :: forall a. CheckResult a -> a
cr_ret = ann
ann } = do
cov_info <- FormatReportWarningsMode ann -> ann -> DsM CIRB
forall ann. FormatReportWarningsMode ann -> ann -> DsM CIRB
collectInMode FormatReportWarningsMode ann
report_mode ann
ann
dflags <- getDynFlags
reportWarnings dflags report_mode ctx vars cr{cr_ret=cov_info}
reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
reportWarnings :: forall ann.
DynFlags
-> FormatReportWarningsMode ann
-> DsMatchContext
-> [Id]
-> CheckResult CIRB
-> DsM ()
reportWarnings DynFlags
dflags FormatReportWarningsMode ann
report_mode (DsMatchContext HsMatchContextRn
kind SrcSpan
loc) [Id]
vars
CheckResult { cr_ret :: forall a. CheckResult a -> a
cr_ret = CIRB { cirb_inacc :: CIRB -> OrdList SrcInfo
cirb_inacc = OrdList SrcInfo
inaccessible_rhss
, cirb_red :: CIRB -> OrdList SrcInfo
cirb_red = OrdList SrcInfo
redundant_rhss
, cirb_bangs :: CIRB -> OrdList SrcInfo
cirb_bangs = OrdList SrcInfo
redundant_bangs }
, cr_uncov :: forall a. CheckResult a -> Nablas
cr_uncov = Nablas
uncovered
, cr_approx :: forall a. CheckResult a -> Precision
cr_approx = Precision
precision }
= Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
flag_i Bool -> Bool -> Bool
|| Bool
flag_u Bool -> Bool -> Bool
|| Bool
flag_b) (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$ do
unc_examples <- GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nablas -> DsM [Nabla]
getNFirstUncovered GenerateInhabitingPatternsMode
gen_mode [Id]
vars (Int
maxPatterns Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Nablas
uncovered
let exists_r = Bool
flag_i Bool -> Bool -> Bool
&& OrdList SrcInfo -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull OrdList SrcInfo
redundant_rhss
exists_i = Bool
flag_i Bool -> Bool -> Bool
&& OrdList SrcInfo -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull OrdList SrcInfo
inaccessible_rhss
exists_u = Bool
flag_u Bool -> Bool -> Bool
&& [Nabla] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Nabla]
unc_examples
exists_b = Bool
flag_b Bool -> Bool -> Bool
&& OrdList SrcInfo -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull OrdList SrcInfo
redundant_bangs
approx = Precision
precision Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
Approximate
when (approx && (exists_u || exists_i)) $
putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags)))
when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (DsMessage -> DsM ()
diagnosticDs (HsMatchContextRn -> SDoc -> DsMessage
DsRedundantBangPatterns HsMatchContextRn
kind SDoc
q))
when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (DsMessage -> DsM ()
diagnosticDs (HsMatchContextRn -> SDoc -> DsMessage
DsOverlappingPatterns HsMatchContextRn
kind SDoc
q))
when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (DsMessage -> DsM ()
diagnosticDs (HsMatchContextRn -> SDoc -> DsMessage
DsInaccessibleRhs HsMatchContextRn
kind SDoc
q))
when exists_u $
putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples))
where
flag_i :: Bool
flag_i = DynFlags -> HsMatchContext (GenLocated SrcSpanAnnN Name) -> Bool
forall fn. DynFlags -> HsMatchContext fn -> Bool
overlapping DynFlags
dflags HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
kind
flag_u :: Bool
flag_u = DynFlags -> HsMatchContext (GenLocated SrcSpanAnnN Name) -> Bool
forall fn. DynFlags -> HsMatchContext fn -> Bool
exhaustive DynFlags
dflags HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
kind
flag_b :: Bool
flag_b = DynFlags -> Bool
redundantBang DynFlags
dflags
check_type :: ExhaustivityCheckType
check_type = Maybe WarningFlag -> ExhaustivityCheckType
ExhaustivityCheckType (HsMatchContext (GenLocated SrcSpanAnnN Name) -> Maybe WarningFlag
forall fn. HsMatchContext fn -> Maybe WarningFlag
exhaustiveWarningFlag HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
kind)
gen_mode :: GenerateInhabitingPatternsMode
gen_mode = case FormatReportWarningsMode ann
report_mode of
FormatReportWarningsMode ann
ReportEmptyCase -> GenerateInhabitingPatternsMode
CaseSplitTopLevel
FormatReportWarningsMode ann
_ -> GenerateInhabitingPatternsMode
MinimalCover
maxPatterns :: Int
maxPatterns = DynFlags -> Int
maxUncoveredPatterns DynFlags
dflags
getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla]
getNFirstUncovered :: GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nablas -> DsM [Nabla]
getNFirstUncovered GenerateInhabitingPatternsMode
mode [Id]
vars Int
n (MkNablas Bag Nabla
nablas) = Int -> [Nabla] -> DsM [Nabla]
go Int
n (Bag Nabla -> [Nabla]
forall a. Bag a -> [a]
bagToList Bag Nabla
nablas)
where
go :: Int -> [Nabla] -> DsM [Nabla]
go Int
0 [Nabla]
_ = [Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go Int
_ [] = [Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go Int
n (Nabla
nabla:[Nabla]
nablas) = do
front <- GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
vars Int
n Nabla
nabla
back <- go (n - length front) nablas
pure (front ++ back)
locallyExtendPmNablas :: DsM a -> (Nablas -> DsM Nablas) -> DsM a
locallyExtendPmNablas :: forall a. DsM a -> (Nablas -> DsM Nablas) -> DsM a
locallyExtendPmNablas DsM a
k Nablas -> DsM Nablas
ext = do
nablas <- DsM Nablas
getLdiNablas
nablas' <- unsafeInterleaveM $ ext nablas
updPmNablas nablas' k
addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a
addTyCs :: forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCs Origin
origin Bag Id
ev_vars DsM a
thing_inside
| Bag Id -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Id
ev_vars
= DsM a
thing_inside
| Bool
otherwise
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if needToRunPmCheck dflags origin
then locallyExtendPmNablas thing_inside $ \Nablas
nablas ->
Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas Nablas
nablas (PredType -> PhiCt
PhiTyCt (PredType -> PhiCt) -> (Id -> PredType) -> Id -> PhiCt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PredType
evVarPred (Id -> PhiCt) -> Bag Id -> PhiCts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bag Id
ev_vars)
else thing_inside }
addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs :: forall a. [CoreExpr] -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs [] [Id]
_ DsM a
k = DsM a
k
addCoreScrutTmCs (CoreExpr
scr:[CoreExpr]
scrs) (Id
x:[Id]
xs) DsM a
k
= DsM a -> (Nablas -> DsM Nablas) -> DsM a
forall a. DsM a -> (Nablas -> DsM Nablas) -> DsM a
locallyExtendPmNablas ([CoreExpr] -> [Id] -> DsM a -> DsM a
forall a. [CoreExpr] -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs [CoreExpr]
scrs [Id]
xs DsM a
k) ((Nablas -> DsM Nablas) -> DsM a)
-> (Nablas -> DsM Nablas) -> DsM a
forall a b. (a -> b) -> a -> b
$ \Nablas
nablas ->
Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas Nablas
nablas (PhiCt -> PhiCts
forall a. a -> Bag a
unitBag (Id -> CoreExpr -> PhiCt
PhiCoreCt Id
x CoreExpr
scr))
addCoreScrutTmCs [CoreExpr]
_ [Id]
_ DsM a
_ = String -> DsM a
forall a. HasCallStack => String -> a
panic String
"addCoreScrutTmCs: numbers of scrutinees and match ids differ"
addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
addHsScrutTmCs :: forall a. [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
addHsScrutTmCs [LHsExpr GhcTc]
scrs [Id]
vars DsM a
k = do
scr_es <- (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
scrs
addCoreScrutTmCs scr_es vars k