{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.HsToCore.Pmc.Utils (
tracePm, traceWhenFailPm, mkPmId,
allPmCheckWarnings, overlapping, exhaustive, redundantBang,
exhaustiveWarningFlag,
isMatchContextPmChecked, needToRunPmCheck
) where
import GHC.Prelude
import GHC.Types.Basic (Origin(..), isGenerated)
import GHC.Driver.Session
import GHC.Hs
import GHC.Core.Type
import GHC.Data.FastString
import GHC.Data.IOEnv
import GHC.Data.Maybe
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Unique.Supply
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.HsToCore.Monad
import Control.Monad
tracePm :: String -> SDoc -> DsM ()
tracePm :: String -> SDoc -> DsM ()
tracePm String
herald SDoc
doc = do
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
NamePprCtx
name_ppr_ctx <- DsM NamePprCtx
mkNamePprCtxDs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe' Logger
logger NamePprCtx
name_ppr_ctx
DumpFlag
Opt_D_dump_ec_trace String
"" DumpFormat
FormatText (forall doc. IsLine doc => String -> doc
text String
herald forall doc. IsDoc doc => doc -> doc -> doc
$$ (Int -> SDoc -> SDoc
nest Int
2 SDoc
doc))
{-# INLINE tracePm #-}
traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a
traceWhenFailPm :: forall a.
String
-> SDoc
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
traceWhenFailPm String
herald SDoc
doc MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
act = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ do
Maybe a
mb_a <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
act
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe a
mb_a) forall a b. (a -> b) -> a -> b
$ String -> SDoc -> DsM ()
tracePm String
herald SDoc
doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
mb_a
{-# INLINE traceWhenFailPm #-}
mkPmId :: Type -> DsM Id
mkPmId :: Type -> DsM Id
mkPmId Type
ty = forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Unique
unique ->
let occname :: OccName
occname = FastString -> OccName
mkVarOccFS forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"pm"
name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
unique OccName
occname SrcSpan
noSrcSpan
in forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> Type -> Id
mkLocalIdOrCoVar Name
name Type
ManyTy Type
ty)
{-# NOINLINE mkPmId #-}
allPmCheckWarnings :: [WarningFlag]
allPmCheckWarnings :: [WarningFlag]
allPmCheckWarnings =
[ WarningFlag
Opt_WarnIncompletePatterns
, WarningFlag
Opt_WarnIncompleteUniPatterns
, WarningFlag
Opt_WarnIncompletePatternsRecUpd
, WarningFlag
Opt_WarnOverlappingPatterns
]
overlapping :: DynFlags -> HsMatchContext id -> Bool
overlapping :: forall id. DynFlags -> HsMatchContext id -> Bool
overlapping DynFlags
_ HsMatchContext id
RecUpd = Bool
False
overlapping DynFlags
dflags HsMatchContext id
_ = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnOverlappingPatterns DynFlags
dflags
exhaustive :: DynFlags -> HsMatchContext id -> Bool
exhaustive :: forall id. DynFlags -> HsMatchContext id -> Bool
exhaustive DynFlags
dflags = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (WarningFlag -> DynFlags -> Bool
`wopt` DynFlags
dflags) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag
redundantBang :: DynFlags -> Bool
redundantBang :: DynFlags -> Bool
redundantBang DynFlags
dflags = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnRedundantBangPatterns DynFlags
dflags
exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag :: forall id. HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag FunRhs{} = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag HsMatchContext id
CaseAlt = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag LamCaseAlt{} = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag HsMatchContext id
IfAlt = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag HsMatchContext id
LambdaExpr = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag HsMatchContext id
PatBindRhs = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag HsMatchContext id
PatBindGuards = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag (ArrowMatchCtxt HsArrowMatchContext
c) = HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag HsArrowMatchContext
c
exhaustiveWarningFlag HsMatchContext id
RecUpd = forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatternsRecUpd
exhaustiveWarningFlag HsMatchContext id
ThPatSplice = forall a. Maybe a
Nothing
exhaustiveWarningFlag HsMatchContext id
PatSyn = forall a. Maybe a
Nothing
exhaustiveWarningFlag HsMatchContext id
ThPatQuote = forall a. Maybe a
Nothing
exhaustiveWarningFlag StmtCtxt{} = forall a. Maybe a
Nothing
arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag = \ case
HsArrowMatchContext
ProcExpr -> forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
HsArrowMatchContext
ArrowCaseAlt -> forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
ArrowLamCaseAlt LamCaseVariant
_ -> forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
HsArrowMatchContext
KappaExpr -> forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked :: forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
origin HsMatchContext id
kind
| Origin -> Bool
isGenerated Origin
origin
= Bool
False
| Bool
otherwise
= forall id. DynFlags -> HsMatchContext id -> Bool
overlapping DynFlags
dflags HsMatchContext id
kind Bool -> Bool -> Bool
|| forall id. DynFlags -> HsMatchContext id -> Bool
exhaustive DynFlags
dflags HsMatchContext id
kind
needToRunPmCheck :: DynFlags -> Origin -> Bool
needToRunPmCheck :: DynFlags -> Origin -> Bool
needToRunPmCheck DynFlags
dflags Origin
origin
| Origin -> Bool
isGenerated Origin
origin
= Bool
False
| Bool
otherwise
= forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull (forall a. (a -> Bool) -> [a] -> [a]
filter (WarningFlag -> DynFlags -> Bool
`wopt` DynFlags
dflags) [WarningFlag]
allPmCheckWarnings)