{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
module GHC.HsToCore.Pmc (
pmcPatBind, pmcMatches, pmcGRHSs,
isMatchContextPmChecked,
addTyCs, addCoreScrutTmCs, addHsScrutTmCs
) 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(..))
import GHC.Core (CoreExpr)
import GHC.Driver.Session
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)
import GHC.Tc.Utils.TcType (evVarPred)
import GHC.Tc.Utils.Monad (updTopFlags)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
import GHC.HsToCore.Monad
import GHC.Data.Bag
import GHC.Data.IOEnv (unsafeInterleaveM)
import GHC.Data.OrdList
import GHC.Utils.Monad (mapMaybeM)
import Control.Monad (when, forM_)
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Coerce
getLdiNablas :: DsM Nablas
getLdiNablas :: DsM Nablas
getLdiNablas = do
Nablas
nablas <- DsM Nablas
getPmNablas
Nablas -> DsM Bool
isInhabited Nablas
nablas DsM Bool -> (Bool -> DsM Nablas) -> DsM Nablas
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 -> 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 ()
pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()
pmcPatBind ctxt :: DsMatchContext
ctxt@(DsMatchContext HsMatchContext GhcRn
PatBindRhs SrcSpan
loc) Id
var Pat GhcTc
p = do
!Nablas
missing <- DsM Nablas
getLdiNablas
PmPatBind Pre
pat_bind <- DsM (PmPatBind Pre) -> DsM (PmPatBind Pre)
forall a. DsM a -> DsM a
noCheckDs (DsM (PmPatBind Pre) -> DsM (PmPatBind Pre))
-> DsM (PmPatBind Pre) -> DsM (PmPatBind Pre)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
desugarPatBind SrcSpan
loc Id
var Pat GhcTc
p
String -> SDoc -> DsM ()
tracePm String
"pmcPatBind {" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [DsMatchContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DsMatchContext
ctxt, Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var, Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p, PmPatBind Pre -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmPatBind Pre
pat_bind, Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr Nablas
missing])
CheckResult (PmPatBind Post)
result <- CheckAction (PmPatBind Post)
-> Nablas -> DsM (CheckResult (PmPatBind Post))
forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
unCA (PmPatBind Pre -> CheckAction (PmPatBind Post)
checkPatBind PmPatBind Pre
pat_bind) Nablas
missing
String -> SDoc -> DsM ()
tracePm String
"}: " (Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CheckResult (PmPatBind Post) -> Nablas
forall a. CheckResult a -> Nablas
cr_uncov CheckResult (PmPatBind Post)
result))
FormatReportWarningsMode (PmPatBind Post)
-> DsMatchContext -> [Id] -> CheckResult (PmPatBind Post) -> DsM ()
forall ann.
FormatReportWarningsMode ann
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings FormatReportWarningsMode (PmPatBind Post)
ReportPatBind DsMatchContext
ctxt [Id
var] CheckResult (PmPatBind Post)
result
pmcPatBind DsMatchContext
_ Id
_ Pat GhcTc
_ = () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pmcGRHSs
:: HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc)
-> DsM (NonEmpty Nablas)
pmcGRHSs :: HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContext GhcRn
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
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SrcSpan)
-> [GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
(SrcSpanAnn' (EpAnn NoEpAnns))
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
grhss)
ctxt :: DsMatchContext
ctxt = HsMatchContext GhcRn -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext GhcRn
hs_ctxt SrcSpan
combined_loc
!Nablas
missing <- DsM Nablas
getLdiNablas
PmGRHSs Pre
matches <- DsM (PmGRHSs Pre) -> DsM (PmGRHSs Pre)
forall a. DsM a -> DsM a
noCheckDs (DsM (PmGRHSs Pre) -> DsM (PmGRHSs Pre))
-> DsM (PmGRHSs Pre) -> DsM (PmGRHSs Pre)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs SrcSpan
combined_loc SDoc
forall doc. IsOutput doc => doc
empty GRHSs GhcTc (LHsExpr GhcTc)
guards
String -> SDoc -> DsM ()
tracePm String
"pmcGRHSs" (SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [DsMatchContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DsMatchContext
ctxt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Guards:"])
Int
2
(HsMatchContext GhcRn
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> SDoc
forall (idR :: Pass) body passL.
(OutputableBndrId idR, Outputable body) =>
HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs HsMatchContext GhcRn
hs_ctxt GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
guards SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr Nablas
missing))
CheckResult (PmGRHSs Post)
result <- CheckAction (PmGRHSs Post)
-> Nablas -> DsM (CheckResult (PmGRHSs Post))
forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
unCA (PmGRHSs Pre -> CheckAction (PmGRHSs Post)
checkGRHSs PmGRHSs Pre
matches) Nablas
missing
String -> SDoc -> DsM ()
tracePm String
"}: " (Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CheckResult (PmGRHSs Post) -> Nablas
forall a. CheckResult a -> Nablas
cr_uncov CheckResult (PmGRHSs Post)
result))
FormatReportWarningsMode (PmGRHSs Post)
-> DsMatchContext -> [Id] -> CheckResult (PmGRHSs Post) -> DsM ()
forall ann.
FormatReportWarningsMode ann
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings FormatReportWarningsMode (PmGRHSs Post)
ReportGRHSs DsMatchContext
ctxt [] CheckResult (PmGRHSs Post)
result
NonEmpty Nablas -> DsM (NonEmpty Nablas)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PmGRHSs Post -> NonEmpty Nablas
ldiGRHSs (CheckResult (PmGRHSs Post) -> PmGRHSs Post
forall a. CheckResult a -> a
cr_ret CheckResult (PmGRHSs Post)
result))
pmcMatches
:: DsMatchContext
-> [Id]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> DsM [(Nablas, NonEmpty Nablas)]
pmcMatches :: DsMatchContext
-> [Id]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> DsM [(Nablas, NonEmpty Nablas)]
pmcMatches DsMatchContext
ctxt [Id]
vars [LMatch GhcTc (LHsExpr GhcTc)]
matches = {-# SCC "pmcMatches" #-} do
!Nablas
missing <- DsM Nablas
getLdiNablas
String -> SDoc -> DsM ()
tracePm String
"pmcMatches {" (SDoc -> DsM ()) -> SDoc -> DsM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [DsMatchContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DsMatchContext
ctxt, [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
vars, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Matches:"])
Int
2
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SDoc)
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [LMatch GhcTc (LHsExpr GhcTc)]
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr Nablas
missing)
case [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Maybe
(NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LMatch GhcTc (LHsExpr GhcTc)]
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
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
PmEmptyCase
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
CheckResult PmEmptyCase
result <- CheckAction PmEmptyCase -> Nablas -> DsM (CheckResult PmEmptyCase)
forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
unCA (PmEmptyCase -> CheckAction PmEmptyCase
checkEmptyCase PmEmptyCase
empty_case) Nablas
missing
String -> SDoc -> DsM ()
tracePm String
"}: " (Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CheckResult PmEmptyCase -> Nablas
forall a. CheckResult a -> Nablas
cr_uncov CheckResult PmEmptyCase
result))
FormatReportWarningsMode PmEmptyCase
-> DsMatchContext -> [Id] -> CheckResult PmEmptyCase -> DsM ()
forall ann.
FormatReportWarningsMode ann
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings FormatReportWarningsMode PmEmptyCase
ReportEmptyCase DsMatchContext
ctxt [Id]
vars CheckResult PmEmptyCase
result
[(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
matches -> do
PmMatchGroup Pre
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
CheckResult (PmMatchGroup Post)
result <- {-# SCC "checkMatchGroup" #-}
CheckAction (PmMatchGroup Post)
-> Nablas -> DsM (CheckResult (PmMatchGroup Post))
forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
unCA (PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
checkMatchGroup PmMatchGroup Pre
matches) Nablas
missing
String -> SDoc -> DsM ()
tracePm String
"}: " (Nablas -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CheckResult (PmMatchGroup Post) -> Nablas
forall a. CheckResult a -> Nablas
cr_uncov CheckResult (PmMatchGroup Post)
result))
{-# SCC "formatReportWarnings" #-} FormatReportWarningsMode (PmMatchGroup Post)
-> DsMatchContext
-> [Id]
-> CheckResult (PmMatchGroup Post)
-> DsM ()
forall ann.
FormatReportWarningsMode ann
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings FormatReportWarningsMode (PmMatchGroup Post)
ReportMatchGroup DsMatchContext
ctxt [Id]
vars CheckResult (PmMatchGroup Post)
result
[(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty (Nablas, NonEmpty Nablas) -> [(Nablas, NonEmpty Nablas)]
forall a. NonEmpty a -> [a]
NE.toList (PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
ldiMatchGroup (CheckResult (PmMatchGroup Post) -> PmMatchGroup Post
forall a. CheckResult a -> a
cr_ret CheckResult (PmMatchGroup Post)
result)))
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
Bool
is_covered <- Nablas -> DsM Bool
isInhabited Nablas
cov
Bool
may_diverge <- Nablas -> DsM Bool
isInhabited Nablas
div
[SrcInfo]
red_bangs <- (((Nablas, SrcInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
-> [(Nablas, SrcInfo)] -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo])
-> [(Nablas, SrcInfo)]
-> ((Nablas, SrcInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
-> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Nablas, SrcInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
-> [(Nablas, SrcInfo)] -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (OrdList (Nablas, SrcInfo) -> [(Nablas, SrcInfo)]
forall a. OrdList a -> [a]
fromOL OrdList (Nablas, SrcInfo)
bangs) (((Nablas, SrcInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
-> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo])
-> ((Nablas, SrcInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
-> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo]
forall a b. (a -> b) -> a -> b
$ \(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)
(Bool, Bool, OrdList SrcInfo) -> DsM (Bool, Bool, OrdList SrcInfo)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
is_covered, Bool
may_diverge, [SrcInfo] -> OrdList SrcInfo
forall a. [a] -> OrdList a
toOL [SrcInfo]
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
(Bool
_is_covered, Bool
may_diverge, OrdList SrcInfo
red_bangs) <- Post -> DsM (Bool, Bool, OrdList SrcInfo)
testRedSets Post
red
CIRB
cirb <- PmGRHSs Post -> DsM CIRB
cirbsGRHSs PmGRHSs Post
grhss
CIRB -> DsM CIRB
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CIRB -> DsM CIRB) -> CIRB -> DsM CIRB
forall a b. (a -> b) -> a -> b
$ OrdList SrcInfo -> CIRB -> CIRB
addRedundantBangs OrdList SrcInfo
red_bangs
(CIRB -> CIRB) -> CIRB -> CIRB
forall a b. (a -> b) -> a -> b
$ Bool -> (CIRB -> CIRB) -> CIRB -> CIRB
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
may_diverge CIRB -> CIRB
ensureOneNotRedundant
(CIRB -> CIRB) -> CIRB -> CIRB
forall a b. (a -> b) -> a -> b
$ CIRB
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
(Bool
is_covered, Bool
may_diverge, OrdList SrcInfo
red_bangs) <- Post -> DsM (Bool, Bool, OrdList SrcInfo)
testRedSets Post
red
let cirb :: CIRB
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 }
CIRB -> DsM CIRB
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList SrcInfo -> CIRB -> CIRB
addRedundantBangs OrdList SrcInfo
red_bangs CIRB
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
CIRB
cov_info <- FormatReportWarningsMode ann -> ann -> DsM CIRB
forall ann. FormatReportWarningsMode ann -> ann -> DsM CIRB
collectInMode FormatReportWarningsMode ann
report_mode ann
ann
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags
-> FormatReportWarningsMode ann
-> DsMatchContext
-> [Id]
-> CheckResult CIRB
-> DsM ()
forall ann.
DynFlags
-> FormatReportWarningsMode ann
-> DsMatchContext
-> [Id]
-> CheckResult CIRB
-> DsM ()
reportWarnings DynFlags
dflags FormatReportWarningsMode ann
report_mode DsMatchContext
ctx [Id]
vars CheckResult ann
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 HsMatchContext GhcRn
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
[Nabla]
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
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
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
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
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 :: Bool
approx = Precision
precision Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
Approximate
Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
approx Bool -> Bool -> Bool
&& (Bool
exists_u Bool -> Bool -> Bool
|| Bool
exists_i)) (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsMessage -> DsM ()
diagnosticDs (Int -> DsMessage
DsMaxPmCheckModelsReached (DynFlags -> Int
maxPmCheckModels DynFlags
dflags)))
Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_b (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$ OrdList SrcInfo -> (SrcInfo -> DsM ()) -> DsM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ OrdList SrcInfo
redundant_bangs ((SrcInfo -> DsM ()) -> DsM ()) -> (SrcInfo -> DsM ()) -> DsM ()
forall a b. (a -> b) -> a -> b
$ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (DsMessage -> DsM ()
diagnosticDs (HsMatchContext GhcRn -> SDoc -> DsMessage
DsRedundantBangPatterns HsMatchContext GhcRn
kind SDoc
q))
Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_r (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$ OrdList SrcInfo -> (SrcInfo -> DsM ()) -> DsM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ OrdList SrcInfo
redundant_rhss ((SrcInfo -> DsM ()) -> DsM ()) -> (SrcInfo -> DsM ()) -> DsM ()
forall a b. (a -> b) -> a -> b
$ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (DsMessage -> DsM ()
diagnosticDs (HsMatchContext GhcRn -> SDoc -> DsMessage
DsOverlappingPatterns HsMatchContext GhcRn
kind SDoc
q))
Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_i (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$ OrdList SrcInfo -> (SrcInfo -> DsM ()) -> DsM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ OrdList SrcInfo
inaccessible_rhss ((SrcInfo -> DsM ()) -> DsM ()) -> (SrcInfo -> DsM ()) -> DsM ()
forall a b. (a -> b) -> a -> b
$ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (DsMessage -> DsM ()
diagnosticDs (HsMatchContext GhcRn -> SDoc -> DsMessage
DsInaccessibleRhs HsMatchContext GhcRn
kind SDoc
q))
Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_u (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> DsM () -> DsM ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsMessage -> DsM ()
diagnosticDs (HsMatchContext GhcRn
-> ExhaustivityCheckType -> Int -> [Id] -> [Nabla] -> DsMessage
DsNonExhaustivePatterns HsMatchContext GhcRn
kind ExhaustivityCheckType
check_type Int
maxPatterns [Id]
vars [Nabla]
unc_examples))
where
flag_i :: Bool
flag_i = DynFlags -> HsMatchContext GhcRn -> Bool
forall id. DynFlags -> HsMatchContext id -> Bool
overlapping DynFlags
dflags HsMatchContext GhcRn
kind
flag_u :: Bool
flag_u = DynFlags -> HsMatchContext GhcRn -> Bool
forall id. DynFlags -> HsMatchContext id -> Bool
exhaustive DynFlags
dflags HsMatchContext GhcRn
kind
flag_b :: Bool
flag_b = DynFlags -> Bool
redundantBang DynFlags
dflags
check_type :: ExhaustivityCheckType
check_type = Maybe WarningFlag -> ExhaustivityCheckType
ExhaustivityCheckType (HsMatchContext GhcRn -> Maybe WarningFlag
forall id. HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag HsMatchContext GhcRn
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
[Nabla]
front <- GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
vars Int
n Nabla
nabla
[Nabla]
back <- Int -> [Nabla] -> DsM [Nabla]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Nabla] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Nabla]
front) [Nabla]
nablas
[Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Nabla]
front [Nabla] -> [Nabla] -> [Nabla]
forall a. [a] -> [a] -> [a]
++ [Nabla]
back)
locallyExtendPmNablas :: (Nablas -> DsM Nablas) -> DsM a -> DsM a
locallyExtendPmNablas :: forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
locallyExtendPmNablas Nablas -> DsM Nablas
ext DsM a
k = do
Nablas
nablas <- DsM Nablas
getLdiNablas
Nablas
nablas' <- DsM Nablas -> DsM Nablas
forall env a. IOEnv env a -> IOEnv env a
unsafeInterleaveM (DsM Nablas -> DsM Nablas) -> DsM Nablas -> DsM Nablas
forall a b. (a -> b) -> a -> b
$ Nablas -> DsM Nablas
ext Nablas
nablas
Nablas -> DsM a -> DsM a
forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
nablas' DsM a
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
m = do
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> (DsM a -> DsM a) -> DsM a -> DsM a
forall a. Bool -> (a -> a) -> a -> a
applyWhen (DynFlags -> Origin -> Bool
needToRunPmCheck DynFlags
dflags Origin
origin)
((Nablas -> DsM Nablas) -> DsM a -> DsM a
forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
locallyExtendPmNablas ((Nablas -> DsM Nablas) -> DsM a -> DsM a)
-> (Nablas -> DsM Nablas) -> DsM a -> DsM a
forall a b. (a -> b) -> a -> b
$ \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))
DsM a
m
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 =
((Nablas -> DsM Nablas) -> DsM a -> DsM a)
-> DsM a -> (Nablas -> DsM Nablas) -> DsM a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Nablas -> DsM Nablas) -> DsM a -> DsM a
forall a. (Nablas -> DsM Nablas) -> DsM a -> 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
[CoreExpr]
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
[CoreExpr] -> [Id] -> DsM a -> DsM a
forall a. [CoreExpr] -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs [CoreExpr]
scr_es [Id]
vars DsM a
k