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 herald doc = do
logger <- getLogger
printer <- mkPrintUnqualifiedDs
liftIO $ putDumpFileMaybe' logger printer
Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))
traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a
traceWhenFailPm herald doc act = MaybeT $ do
mb_a <- runMaybeT act
when (isNothing mb_a) $ tracePm herald doc
pure mb_a
mkPmId :: Type -> DsM Id
mkPmId ty = getUniqueM >>= \unique ->
let occname = mkVarOccFS $ fsLit "pm"
name = mkInternalName unique occname noSrcSpan
in return (mkLocalIdOrCoVar name Many ty)
allPmCheckWarnings :: [WarningFlag]
allPmCheckWarnings =
[ Opt_WarnIncompletePatterns
, Opt_WarnIncompleteUniPatterns
, Opt_WarnIncompletePatternsRecUpd
, Opt_WarnOverlappingPatterns
]
overlapping :: DynFlags -> HsMatchContext id -> Bool
overlapping _ RecUpd = False
overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags
exhaustive :: DynFlags -> HsMatchContext id -> Bool
exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
redundantBang :: DynFlags -> Bool
redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags
exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag FunRhs{} = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag LamCaseAlt{} = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c
exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
exhaustiveWarningFlag ThPatSplice = Nothing
exhaustiveWarningFlag PatSyn = Nothing
exhaustiveWarningFlag ThPatQuote = Nothing
exhaustiveWarningFlag StmtCtxt{} = Nothing
arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag = \ case
ProcExpr -> Just Opt_WarnIncompleteUniPatterns
ArrowCaseAlt -> Just Opt_WarnIncompletePatterns
ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns
KappaExpr -> Just Opt_WarnIncompleteUniPatterns
isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked dflags origin kind
| isGenerated origin
= False
| otherwise
= overlapping dflags kind || exhaustive dflags kind
needToRunPmCheck :: DynFlags -> Origin -> Bool
needToRunPmCheck dflags origin
| isGenerated origin
= False
| otherwise
= notNull (filter (`wopt` dflags) allPmCheckWarnings)