{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
module GHC.HsToCore.Pmc (
pmcPatBind, pmcMatches, pmcGRHSs,
isMatchContextPmChecked,
addTyCs, addCoreScrutTmCs, addHsScrutTmCs
) where
#include "HsVersions.h"
import GHC.Prelude
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.HsToCore.Pmc.Ppr
import GHC.Types.Basic (Origin(..))
import GHC.Core (CoreExpr)
import GHC.Driver.Session
import GHC.Driver.Env
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.Types
import GHC.Tc.Utils.TcType (evVarPred)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
import GHC.HsToCore.Monad
import GHC.Data.Bag
import GHC.Data.IOEnv (updEnv, 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Nablas
nablas
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Nablas
initNablas
noCheckDs :: DsM a -> DsM a
noCheckDs :: forall a. DsM a -> DsM a
noCheckDs DsM a
k = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let dflags' :: DynFlags
dflags' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> WarningFlag -> DynFlags
wopt_unset DynFlags
dflags [WarningFlag]
allPmCheckWarnings
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\Env DsGblEnv DsLclEnv
env -> Env DsGblEnv DsLclEnv
env{env_top :: HscEnv
env_top = (forall gbl lcl. Env gbl lcl -> HscEnv
env_top Env DsGblEnv DsLclEnv
env) {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags'} }) DsM a
k
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 <- forall a. DsM a -> DsM a
noCheckDs 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
vcat [forall a. Outputable a => a -> SDoc
ppr DsMatchContext
ctxt, forall a. Outputable a => a -> SDoc
ppr Id
var, forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p, forall a. Outputable a => a -> SDoc
ppr PmPatBind Pre
pat_bind, forall a. Outputable a => a -> SDoc
ppr Nablas
missing])
CheckResult (PmPatBind Post)
result <- 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
"}: " (forall a. Outputable a => a -> SDoc
ppr (forall a. CheckResult a -> Nablas
cr_uncov CheckResult (PmPatBind Post)
result))
forall ann.
(ann -> DsM CIRB)
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings PmPatBind Post -> DsM CIRB
cirbsPatBind DsMatchContext
ctxt [Id
var] CheckResult (PmPatBind Post)
result
pmcPatBind DsMatchContext
_ Id
_ Pat GhcTc
_ = 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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> l
getLoc [LGRHS GhcTc (LHsExpr 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 <- forall a. DsM a -> DsM a
noCheckDs forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs SrcSpan
combined_loc SDoc
empty GRHSs GhcTc (LHsExpr GhcTc)
guards
String -> SDoc -> DsM ()
tracePm String
"pmcGRHSs" (SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr DsMatchContext
ctxt
, String -> SDoc
text String
"Guards:"])
Int
2
(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)
guards SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Nablas
missing))
CheckResult (PmGRHSs Post)
result <- 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
"}: " (forall a. Outputable a => a -> SDoc
ppr (forall a. CheckResult a -> Nablas
cr_uncov CheckResult (PmGRHSs Post)
result))
forall ann.
(ann -> DsM CIRB)
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings PmGRHSs Post -> DsM CIRB
cirbsGRHSs DsMatchContext
ctxt [] CheckResult (PmGRHSs Post)
result
forall (m :: * -> *) a. Monad m => a -> m a
return (PmGRHSs Post -> NonEmpty Nablas
ldiGRHSs (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 = do
!Nablas
missing <- DsM Nablas
getLdiNablas
String -> SDoc -> DsM ()
tracePm String
"pmcMatches {" forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr DsMatchContext
ctxt, forall a. Outputable a => a -> SDoc
ppr [Id]
vars, String -> SDoc
text String
"Matches:"])
Int
2
([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LMatch GhcTc (LHsExpr GhcTc)]
matches) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Nablas
missing)
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [LMatch GhcTc (LHsExpr GhcTc)]
matches of
Maybe
(NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
Nothing -> do
let var :: Id
var = forall a. [a] -> a
only [Id]
vars
PmEmptyCase
empty_case <- forall a. DsM a -> DsM a
noCheckDs forall a b. (a -> b) -> a -> b
$ Id -> DsM PmEmptyCase
desugarEmptyCase Id
var
CheckResult PmEmptyCase
result <- forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
unCA (PmEmptyCase -> CheckAction PmEmptyCase
checkEmptyCase PmEmptyCase
empty_case) Nablas
missing
String -> SDoc -> DsM ()
tracePm String
"}: " (forall a. Outputable a => a -> SDoc
ppr (forall a. CheckResult a -> Nablas
cr_uncov CheckResult PmEmptyCase
result))
forall ann.
(ann -> DsM CIRB)
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings PmEmptyCase -> DsM CIRB
cirbsEmptyCase DsMatchContext
ctxt [Id]
vars CheckResult PmEmptyCase
result
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
matches -> do
PmMatchGroup Pre
matches <- forall a. DsM a -> DsM a
noCheckDs forall a b. (a -> b) -> a -> b
$ [Id]
-> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
-> DsM (PmMatchGroup Pre)
desugarMatches [Id]
vars NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
matches
CheckResult (PmMatchGroup Post)
result <- 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
"}: " (forall a. Outputable a => a -> SDoc
ppr (forall a. CheckResult a -> Nablas
cr_uncov CheckResult (PmMatchGroup Post)
result))
forall ann.
(ann -> DsM CIRB)
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings PmMatchGroup Post -> DsM CIRB
cirbsMatchGroup DsMatchContext
ctxt [Id]
vars CheckResult (PmMatchGroup Post)
result
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. NonEmpty a -> [a]
NE.toList (PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
ldiMatchGroup (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 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 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
(<>) = 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 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty 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 :: OrdList SrcInfo
cirb_inacc = forall a. a -> OrdList a
unitOL SrcInfo
r, cirb_red :: OrdList SrcInfo
cirb_red = OrdList SrcInfo
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 :: OrdList SrcInfo
cirb_bangs = CIRB -> OrdList SrcInfo
cirb_bangs CIRB
cirb forall a. Semigroup a => a -> a -> a
Semi.<> OrdList SrcInfo
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 <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall a. OrdList a -> [a]
fromOL OrdList (Nablas, SrcInfo)
bangs) forall a b. (a -> b) -> a -> b
$ \(Nablas
nablas, SrcInfo
bang) ->
Nablas -> DsM Bool
isInhabited Nablas
nablas forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just SrcInfo
bang)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
is_covered, Bool
may_diverge, 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) =
forall a. Semigroup a => NonEmpty a -> a
Semi.sconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OrdList SrcInfo -> CIRB -> CIRB
addRedundantBangs OrdList SrcInfo
red_bangs
forall a b. (a -> b) -> a -> b
$ forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
may_diverge CIRB -> CIRB
ensureOneNotRedundant
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 }) = forall a. Semigroup a => NonEmpty a -> a
Semi.sconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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 = forall a. Monoid a => a
mempty { cirb_cov :: OrdList SrcInfo
cirb_cov = forall a. a -> OrdList a
unitOL SrcInfo
info }
| Bool
may_diverge = forall a. Monoid a => a
mempty { cirb_inacc :: OrdList SrcInfo
cirb_inacc = forall a. a -> OrdList a
unitOL SrcInfo
info }
| Bool
otherwise = forall a. Monoid a => a
mempty { cirb_red :: OrdList SrcInfo
cirb_red = forall a. a -> OrdList a
unitOL SrcInfo
info }
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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
cirbsPatBind :: PmPatBind Post -> DsM CIRB
cirbsPatBind :: PmPatBind Post -> DsM CIRB
cirbsPatBind = coerce :: forall a b. Coercible a b => a -> b
coerce PmGRHS Post -> DsM CIRB
cirbsGRHS
formatReportWarnings :: (ann -> DsM CIRB) -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings :: forall ann.
(ann -> DsM CIRB)
-> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
formatReportWarnings ann -> DsM CIRB
collect DsMatchContext
ctx [Id]
vars cr :: CheckResult ann
cr@CheckResult { cr_ret :: forall a. CheckResult a -> a
cr_ret = ann
ann } = do
CIRB
cov_info <- ann -> DsM CIRB
collect ann
ann
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
reportWarnings DynFlags
dflags DsMatchContext
ctx [Id]
vars CheckResult ann
cr{cr_ret :: CIRB
cr_ret=CIRB
cov_info}
reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
reportWarnings DynFlags
dflags ctx :: DsMatchContext
ctx@(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 }
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
flag_i Bool -> Bool -> Bool
|| Bool
flag_u Bool -> Bool -> Bool
|| Bool
flag_b) forall a b. (a -> b) -> a -> b
$ do
[Nabla]
unc_examples <- [Id] -> Int -> Nablas -> DsM [Nabla]
getNFirstUncovered [Id]
vars (Int
maxPatterns forall a. Num a => a -> a -> a
+ Int
1) Nablas
uncovered
let exists_r :: Bool
exists_r = Bool
flag_i Bool -> Bool -> 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
&& forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull OrdList SrcInfo
inaccessible_rhss
exists_u :: Bool
exists_u = Bool
flag_u Bool -> Bool -> Bool
&& forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Nabla]
unc_examples
exists_b :: Bool
exists_b = Bool
flag_b Bool -> Bool -> Bool
&& forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull OrdList SrcInfo
redundant_bangs
approx :: Bool
approx = Precision
precision forall a. Eq a => a -> a -> Bool
== Precision
Approximate
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
approx Bool -> Bool -> Bool
&& (Bool
exists_u Bool -> Bool -> Bool
|| Bool
exists_i)) forall a b. (a -> b) -> a -> b
$
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (WarnReason -> SDoc -> DsM ()
warnDs WarnReason
NoReason SDoc
approx_msg)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_b forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ OrdList SrcInfo
redundant_bangs forall a b. (a -> b) -> a -> b
$ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantBangPatterns)
(SDoc -> String -> SDoc
pprEqn SDoc
q String
"has redundant bang"))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_r forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ OrdList SrcInfo
redundant_rhss forall a b. (a -> b) -> a -> b
$ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnOverlappingPatterns)
(SDoc -> String -> SDoc
pprEqn SDoc
q String
"is redundant"))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_i forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ OrdList SrcInfo
inaccessible_rhss forall a b. (a -> b) -> a -> b
$ \(SrcInfo (L SrcSpan
l SDoc
q)) ->
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
l (WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnOverlappingPatterns)
(SDoc -> String -> SDoc
pprEqn SDoc
q String
"has inaccessible right hand side"))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists_u forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc forall a b. (a -> b) -> a -> b
$ WarnReason -> SDoc -> DsM ()
warnDs WarnReason
flag_u_reason forall a b. (a -> b) -> a -> b
$
[Id] -> [Nabla] -> SDoc
pprEqns [Id]
vars [Nabla]
unc_examples
where
flag_i :: Bool
flag_i = forall id. DynFlags -> HsMatchContext id -> Bool
overlapping DynFlags
dflags HsMatchContext GhcRn
kind
flag_u :: Bool
flag_u = forall id. DynFlags -> HsMatchContext id -> Bool
exhaustive DynFlags
dflags HsMatchContext GhcRn
kind
flag_b :: Bool
flag_b = DynFlags -> Bool
redundantBang DynFlags
dflags
flag_u_reason :: WarnReason
flag_u_reason = forall b a. b -> (a -> b) -> Maybe a -> b
maybe WarnReason
NoReason WarningFlag -> WarnReason
Reason (forall id. HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag HsMatchContext GhcRn
kind)
maxPatterns :: Int
maxPatterns = DynFlags -> Int
maxUncoveredPatterns DynFlags
dflags
pprEqn :: SDoc -> String -> SDoc
pprEqn SDoc
q String
txt = Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
True DsMatchContext
ctx (String -> SDoc
text String
txt) forall a b. (a -> b) -> a -> b
$ \SDoc -> SDoc
f ->
SDoc -> SDoc
f (SDoc
q SDoc -> SDoc -> SDoc
<+> forall p. HsMatchContext p -> SDoc
matchSeparator HsMatchContext GhcRn
kind SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"...")
pprEqns :: [Id] -> [Nabla] -> SDoc
pprEqns [Id]
vars [Nabla]
nablas = Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
False DsMatchContext
ctx (String -> SDoc
text String
"are non-exhaustive") forall a b. (a -> b) -> a -> b
$ \SDoc -> SDoc
_ ->
case [Id]
vars of
[] -> String -> SDoc
text String
"Guards do not cover entire pattern space"
[Id]
_ -> let us :: [SDoc]
us = forall a b. (a -> b) -> [a] -> [b]
map (\Nabla
nabla -> Nabla -> [Id] -> SDoc
pprUncovered Nabla
nabla [Id]
vars) [Nabla]
nablas
pp_tys :: SDoc
pp_tys = forall a. Outputable a => [a] -> SDoc
pprQuotedList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
vars
in SDoc -> Int -> SDoc -> SDoc
hang
(String -> SDoc
text String
"Patterns of type" SDoc -> SDoc -> SDoc
<+> SDoc
pp_tys SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"not matched:")
Int
4
([SDoc] -> SDoc
vcat (forall a. Int -> [a] -> [a]
take Int
maxPatterns [SDoc]
us) SDoc -> SDoc -> SDoc
$$ forall a. Int -> [a] -> SDoc
dots Int
maxPatterns [SDoc]
us)
approx_msg :: SDoc
approx_msg = [SDoc] -> SDoc
vcat
[ SDoc -> Int -> SDoc -> SDoc
hang
(String -> SDoc
text String
"Pattern match checker ran into -fmax-pmcheck-models="
SDoc -> SDoc -> SDoc
<> Int -> SDoc
int (DynFlags -> Int
maxPmCheckModels DynFlags
dflags)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" limit, so")
Int
2
( SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Redundant clauses might not be reported at all"
SDoc -> SDoc -> SDoc
$$ SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Redundant clauses might be reported as inaccessible"
SDoc -> SDoc -> SDoc
$$ SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Patterns reported as unmatched might actually be matched")
, String -> SDoc
text String
"Increase the limit or resolve the warnings to suppress this message." ]
getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]
getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]
getNFirstUncovered [Id]
vars Int
n (MkNablas Bag Nabla
nablas) = Int -> [Nabla] -> DsM [Nabla]
go Int
n (forall a. Bag a -> [a]
bagToList Bag Nabla
nablas)
where
go :: Int -> [Nabla] -> DsM [Nabla]
go Int
0 [Nabla]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go Int
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go Int
n (Nabla
nabla:[Nabla]
nablas) = do
[Nabla]
front <- [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns [Id]
vars Int
n Nabla
nabla
[Nabla]
back <- Int -> [Nabla] -> DsM [Nabla]
go (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Nabla]
front) [Nabla]
nablas
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Nabla]
front forall a. [a] -> [a] -> [a]
++ [Nabla]
back)
dots :: Int -> [a] -> SDoc
dots :: forall a. Int -> [a] -> SDoc
dots Int
maxPatterns [a]
qs
| [a]
qs forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxPatterns = String -> SDoc
text String
"..."
| Bool
otherwise = SDoc
empty
pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
singular (DsMatchContext HsMatchContext GhcRn
kind SrcSpan
_loc) SDoc
msg (SDoc -> SDoc) -> SDoc
rest_of_msg_fun
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
txt SDoc -> SDoc -> SDoc
<+> SDoc
msg,
[SDoc] -> SDoc
sep [ String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> SDoc
ppr_match SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
':'
, Int -> SDoc -> SDoc
nest Int
4 ((SDoc -> SDoc) -> SDoc
rest_of_msg_fun SDoc -> SDoc
pref)]]
where
txt :: String
txt | Bool
singular = String
"Pattern match"
| Bool
otherwise = String
"Pattern match(es)"
(SDoc
ppr_match, SDoc -> SDoc
pref)
= case HsMatchContext GhcRn
kind of
FunRhs { mc_fun :: forall p. HsMatchContext p -> LIdP p
mc_fun = L SrcSpanAnnN
_ Name
fun }
-> (forall p.
(Outputable (IdP p), UnXRec p) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
kind, \ SDoc
pp -> forall a. Outputable a => a -> SDoc
ppr Name
fun SDoc -> SDoc -> SDoc
<+> SDoc
pp)
HsMatchContext GhcRn
_ -> (forall p.
(Outputable (IdP p), UnXRec p) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
kind, \ SDoc
pp -> SDoc
pp)
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' <- forall env a. IOEnv env a -> IOEnv env a
unsafeInterleaveM forall a b. (a -> b) -> a -> b
$ Nablas -> DsM Nablas
ext Nablas
nablas
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 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall a. Bool -> (a -> a) -> a -> a
applyWhen (DynFlags -> Origin -> Bool
needToRunPmCheck DynFlags
dflags Origin
origin)
(forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
locallyExtendPmNablas forall a b. (a -> b) -> a -> b
$ \Nablas
nablas ->
Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas Nablas
nablas (Kind -> PhiCt
PhiTyCt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
evVarPred forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bag Id
ev_vars))
DsM a
m
addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs :: forall a. Maybe CoreExpr -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs Maybe CoreExpr
Nothing [Id]
_ DsM a
k = DsM a
k
addCoreScrutTmCs (Just CoreExpr
scr) [Id
x] DsM a
k =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
locallyExtendPmNablas DsM a
k forall a b. (a -> b) -> a -> b
$ \Nablas
nablas ->
Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas Nablas
nablas (forall a. a -> Bag a
unitBag (Id -> CoreExpr -> PhiCt
PhiCoreCt Id
x CoreExpr
scr))
addCoreScrutTmCs Maybe CoreExpr
_ [Id]
_ DsM a
_ = forall a. String -> a
panic String
"addCoreScrutTmCs: scrutinee, but more than one match id"
addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
addHsScrutTmCs :: forall a. Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
addHsScrutTmCs Maybe (LHsExpr GhcTc)
Nothing [Id]
_ DsM a
k = DsM a
k
addHsScrutTmCs (Just LHsExpr GhcTc
scr) [Id]
vars DsM a
k = do
CoreExpr
scr_e <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
scr
forall a. Maybe CoreExpr -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs (forall a. a -> Maybe a
Just CoreExpr
scr_e) [Id]
vars DsM a
k