    {-
    (c) The AQUA Project, Glasgow University, 1993-1998

    -}

    {-# LANGUAGE DeriveFunctor #-}

    module GHC.Core.Opt.Monad (
        -- * Types used in core-to-core passes
        FloatOutSwitches(..),

        -- * The monad
        CoreM, runCoreM,

        mapDynFlagsCoreM, dropSimplCount,

        -- ** Reading from the monad
        getHscEnv, getModule,
        initRuleEnv, getExternalRuleBase,
        getDynFlags, getPackageFamInstEnv,
        getInteractiveContext,
        getUniqMask,
        getNamePprCtx, getSrcSpanM,

        -- ** Writing to the monad
        addSimplCount,

        -- ** Lifting into the monad
        liftIO, liftIOWithCount,

        -- ** Dealing with annotations
        getAnnotations, getFirstAnnotations,

        -- ** Screen output
        putMsg, putMsgS, errorMsg, msg,
        fatalErrorMsg, fatalErrorMsgS,
        debugTraceMsg, debugTraceMsgS,
      ) where

    import GHC.Prelude hiding ( read )

    import GHC.Driver.Session
    import GHC.Driver.Env

    import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )
    import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount )

    import GHC.Types.Annotations
    import GHC.Types.Unique.Supply
    import GHC.Types.Name.Env
    import GHC.Types.SrcLoc
    import GHC.Types.Error

    import GHC.Utils.Error ( errorDiagnostic )
    import GHC.Utils.Outputable as Outputable
    import GHC.Utils.Logger
    import GHC.Utils.Monad

    import GHC.Data.IOEnv hiding     ( liftIO, failM, failWithM )
    import qualified GHC.Data.IOEnv  as IOEnv

    import GHC.Runtime.Context ( InteractiveContext )

    import GHC.Unit.Module
    import GHC.Unit.Module.ModGuts
    import GHC.Unit.External

    import Data.Bifunctor ( bimap )
    import Data.Dynamic
    import Data.Maybe (listToMaybe)
    import Data.Word
    import Control.Monad
    import Control.Applicative ( Alternative(..) )

    data FloatOutSwitches = FloatOutSwitches {
      FloatOutSwitches -> Maybe Int
    floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
                                       -- doing so will abstract over n or fewer
                                       -- value variables
                                       -- Nothing <=> float all lambdas to top level,
                                       --             regardless of how many free variables
                                       -- Just 0 is the vanilla case: float a lambda
                                       --    iff it has no free vars

      FloatOutSwitches -> Bool
    floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                       --            even if they do not escape a lambda
      FloatOutSwitches -> Bool
    floatOutOverSatApps :: Bool,
                                 -- ^ True <=> float out over-saturated applications
                                 --            based on arity information.
                                 -- See Note [Floating over-saturated applications]
                                 -- in GHC.Core.Opt.SetLevels
      FloatOutSwitches -> Bool
    floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.
      }
    instance Outputable FloatOutSwitches where
        ppr :: FloatOutSwitches -> SDoc
    ppr = FloatOutSwitches -> SDoc
    pprFloatOutSwitches

    pprFloatOutSwitches :: FloatOutSwitches -> SDoc
    pprFloatOutSwitches :: FloatOutSwitches -> SDoc
    pprFloatOutSwitches FloatOutSwitches
    sw
      = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "FOS" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> (SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
         [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
    forall a b. (a -> b) -> a -> b
    $
         [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Lam ="    SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Maybe Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (FloatOutSwitches -> Maybe Int
    floatOutLambdas FloatOutSwitches
    sw)
         , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Consts =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (FloatOutSwitches -> Bool
    floatOutConstants FloatOutSwitches
    sw)
         , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "OverSatApps ="   SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (FloatOutSwitches -> Bool
    floatOutOverSatApps FloatOutSwitches
    sw) ])

    {-
    ************************************************************************
    *                                                                      *
                 Monad and carried data structure definitions
    *                                                                      *
    ************************************************************************
    -}

    data CoreReader = CoreReader {
            CoreReader -> HscEnv
    cr_hsc_env             :: HscEnv,
            CoreReader -> RuleBase
    cr_rule_base           :: RuleBase,  -- Home package table rules
            CoreReader -> Module
    cr_module              :: Module,
            CoreReader -> NamePprCtx
    cr_name_ppr_ctx        :: NamePprCtx,
            CoreReader -> SrcSpan
    cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
                                                 -- are at least tagged with the right source file
            CoreReader -> Char
    cr_uniq_mask           :: !Char      -- Mask for creating unique values
    }

    -- Note: CoreWriter used to be defined with data, rather than newtype.  If it
    -- is defined that way again, the cw_simpl_count field, at least, must be
    -- strict to avoid a space leak (#7702).
    newtype CoreWriter = CoreWriter {
            CoreWriter -> SimplCount
    cw_simpl_count :: SimplCount
    }

    emptyWriter :: Bool -- ^ -ddump-simpl-stats
                -> CoreWriter
    emptyWriter :: Bool -> CoreWriter
    emptyWriter Bool
    dump_simpl_stats = CoreWriter {
            cw_simpl_count :: SimplCount
    cw_simpl_count = Bool -> SimplCount
    zeroSimplCount Bool
    dump_simpl_stats
        }

    plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
    plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
    plusWriter CoreWriter
    w1 CoreWriter
    w2 = CoreWriter {
            cw_simpl_count :: SimplCount
    cw_simpl_count = (CoreWriter -> SimplCount
    cw_simpl_count CoreWriter
    w1) SimplCount -> SimplCount -> SimplCount
    `plusSimplCount` (CoreWriter -> SimplCount
    cw_simpl_count CoreWriter
    w2)
        }

    type CoreIOEnv = IOEnv CoreReader

    -- | The monad used by Core-to-Core passes to register simplification statistics.
    --  Also used to have common state (in the form of UniqueSupply) for generating Uniques.
    newtype CoreM a = CoreM { forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM :: CoreIOEnv (a, CoreWriter) }
        deriving ((forall a b. (a -> b) -> CoreM a -> CoreM b)
    -> (forall a b. a -> CoreM b -> CoreM a) -> Functor CoreM
    forall a b. a -> CoreM b -> CoreM a
    forall a b. (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> CoreM a -> CoreM b
    fmap :: forall a b. (a -> b) -> CoreM a -> CoreM b
    $c<$ :: forall a b. a -> CoreM b -> CoreM a
    <$ :: forall a b. a -> CoreM b -> CoreM a
    Functor)

    instance Monad CoreM where
        CoreM a
    mx >>= :: forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
    >>= a -> CoreM b
    f = CoreIOEnv (b, CoreWriter) -> CoreM b
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv (b, CoreWriter) -> CoreM b)
    -> CoreIOEnv (b, CoreWriter) -> CoreM b
    forall a b. (a -> b) -> a -> b
    $ do
                (a
    x, CoreWriter
    w1) <- CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM CoreM a
    mx
                (b
    y, CoreWriter
    w2) <- CoreM b -> CoreIOEnv (b, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM (a -> CoreM b
    f a
    x)
                let w :: CoreWriter
    w = CoreWriter
    w1 CoreWriter -> CoreWriter -> CoreWriter
    `plusWriter` CoreWriter
    w2
                (b, CoreWriter) -> CoreIOEnv (b, CoreWriter)
    forall a. a -> IOEnv CoreReader a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((b, CoreWriter) -> CoreIOEnv (b, CoreWriter))
    -> (b, CoreWriter) -> CoreIOEnv (b, CoreWriter)
    forall a b. (a -> b) -> a -> b
    $ CoreWriter -> (b, CoreWriter) -> (b, CoreWriter)
    forall a b. a -> b -> b
    seq CoreWriter
    w (b
    y, CoreWriter
    w)
                -- forcing w before building the tuple avoids a space leak
                -- (#7702)

    instance Applicative CoreM where
        pure :: forall a. a -> CoreM a
    pure a
    x = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
    -> CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a b. (a -> b) -> a -> b
    $ a -> CoreIOEnv (a, CoreWriter)
    forall a. a -> CoreIOEnv (a, CoreWriter)
    nop a
    x
        <*> :: forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    (<*>) = CoreM (a -> b) -> CoreM a -> CoreM b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap
        CoreM a
    m *> :: forall a b. CoreM a -> CoreM b -> CoreM b
    *> CoreM b
    k = CoreM a
    m CoreM a -> (a -> CoreM b) -> CoreM b
    forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \a
    _ -> CoreM b
    k

    instance Alternative CoreM where
        empty :: forall a. CoreM a
    empty   = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM CoreIOEnv (a, CoreWriter)
    forall a. IOEnv CoreReader a
    forall (f :: * -> *) a. Alternative f => f a
    Control.Applicative.empty
        CoreM a
    m <|> :: forall a. CoreM a -> CoreM a -> CoreM a
    <|> CoreM a
    n = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM CoreM a
    m CoreIOEnv (a, CoreWriter)
    -> CoreIOEnv (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
    forall a.
    IOEnv CoreReader a -> IOEnv CoreReader a -> IOEnv CoreReader a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM CoreM a
    n)

    instance MonadPlus CoreM

    instance MonadUnique CoreM where
        getUniqueSupplyM :: CoreM UniqSupply
    getUniqueSupplyM = do
            Char
    mask <- (CoreReader -> Char) -> CoreM Char
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> Char
    cr_uniq_mask
            IO UniqSupply -> CoreM UniqSupply
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO UniqSupply -> CoreM UniqSupply)
    -> IO UniqSupply -> CoreM UniqSupply
    forall a b. (a -> b) -> a -> b
    $! Char -> IO UniqSupply
    mkSplitUniqSupply Char
    mask

        getUniqueM :: CoreM Unique
    getUniqueM = do
            Char
    mask <- (CoreReader -> Char) -> CoreM Char
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> Char
    cr_uniq_mask
            IO Unique -> CoreM Unique
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Unique -> CoreM Unique) -> IO Unique -> CoreM Unique
    forall a b. (a -> b) -> a -> b
    $! Char -> IO Unique
    uniqFromMask Char
    mask

    runCoreM :: HscEnv
             -> RuleBase
             -> Char -- ^ Mask
             -> Module
             -> NamePprCtx
             -> SrcSpan
             -> CoreM a
             -> IO (a, SimplCount)
    runCoreM :: forall a.
    HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> NamePprCtx
    -> SrcSpan
    -> CoreM a
    -> IO (a, SimplCount)
    runCoreM HscEnv
    hsc_env RuleBase
    rule_base Char
    mask Module
    mod NamePprCtx
    name_ppr_ctx SrcSpan
    loc CoreM a
    m
      = ((a, CoreWriter) -> (a, SimplCount))
    -> IO (a, CoreWriter) -> IO (a, SimplCount)
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (a, CoreWriter) -> (a, SimplCount)
    forall a. (a, CoreWriter) -> (a, SimplCount)
    extract (IO (a, CoreWriter) -> IO (a, SimplCount))
    -> IO (a, CoreWriter) -> IO (a, SimplCount)
    forall a b. (a -> b) -> a -> b
    $ CoreReader
    -> IOEnv CoreReader (a, CoreWriter) -> IO (a, CoreWriter)
    forall env a. env -> IOEnv env a -> IO a
    runIOEnv CoreReader
    reader (IOEnv CoreReader (a, CoreWriter) -> IO (a, CoreWriter))
    -> IOEnv CoreReader (a, CoreWriter) -> IO (a, CoreWriter)
    forall a b. (a -> b) -> a -> b
    $ CoreM a -> IOEnv CoreReader (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM CoreM a
    m
      where
        reader :: CoreReader
    reader = CoreReader {
                cr_hsc_env :: HscEnv
    cr_hsc_env = HscEnv
    hsc_env,
                cr_rule_base :: RuleBase
    cr_rule_base = RuleBase
    rule_base,
                cr_module :: Module
    cr_module = Module
    mod,
                cr_name_ppr_ctx :: NamePprCtx
    cr_name_ppr_ctx = NamePprCtx
    name_ppr_ctx,
                cr_loc :: SrcSpan
    cr_loc = SrcSpan
    loc,
                cr_uniq_mask :: Char
    cr_uniq_mask = Char
    mask
            }

        extract :: (a, CoreWriter) -> (a, SimplCount)
        extract :: forall a. (a, CoreWriter) -> (a, SimplCount)
    extract (a
    value, CoreWriter
    writer) = (a
    value, CoreWriter -> SimplCount
    cw_simpl_count CoreWriter
    writer)

    {-
    ************************************************************************
    *                                                                      *
                 Core combinators, not exported
    *                                                                      *
    ************************************************************************
    -}

    nop :: a -> CoreIOEnv (a, CoreWriter)
    nop :: forall a. a -> CoreIOEnv (a, CoreWriter)
    nop a
    x = do
        Logger
    logger <- HscEnv -> Logger
    hsc_logger (HscEnv -> Logger)
    -> (CoreReader -> HscEnv) -> CoreReader -> Logger
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreReader -> HscEnv
    cr_hsc_env (CoreReader -> Logger)
    -> IOEnv CoreReader CoreReader -> IOEnv CoreReader Logger
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IOEnv CoreReader CoreReader
    forall env. IOEnv env env
    getEnv
        (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
    forall a. a -> IOEnv CoreReader a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    x, Bool -> CoreWriter
    emptyWriter (Bool -> CoreWriter) -> Bool -> CoreWriter
    forall a b. (a -> b) -> a -> b
    $ Logger -> DumpFlag -> Bool
    logHasDumpFlag Logger
    logger DumpFlag
    Opt_D_dump_simpl_stats)

    read :: (CoreReader -> a) -> CoreM a
    read :: forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> a
    f = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
    -> CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a b. (a -> b) -> a -> b
    $ IOEnv CoreReader CoreReader
    forall env. IOEnv env env
    getEnv IOEnv CoreReader CoreReader
    -> (CoreReader -> CoreIOEnv (a, CoreWriter))
    -> CoreIOEnv (a, CoreWriter)
    forall a b.
    IOEnv CoreReader a
    -> (a -> IOEnv CoreReader b) -> IOEnv CoreReader b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (\CoreReader
    r -> a -> CoreIOEnv (a, CoreWriter)
    forall a. a -> CoreIOEnv (a, CoreWriter)
    nop (CoreReader -> a
    f CoreReader
    r))

    write :: CoreWriter -> CoreM ()
    write :: CoreWriter -> CoreM ()
    write CoreWriter
    w = CoreIOEnv ((), CoreWriter) -> CoreM ()
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv ((), CoreWriter) -> CoreM ())
    -> CoreIOEnv ((), CoreWriter) -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ ((), CoreWriter) -> CoreIOEnv ((), CoreWriter)
    forall a. a -> IOEnv CoreReader a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((), CoreWriter
    w)

    -- \subsection{Lifting IO into the monad}

    -- | Lift an 'IOEnv' operation into 'CoreM'
    liftIOEnv :: CoreIOEnv a -> CoreM a
    liftIOEnv :: forall a. CoreIOEnv a -> CoreM a
    liftIOEnv CoreIOEnv a
    mx = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv a
    mx CoreIOEnv a
    -> (a -> CoreIOEnv (a, CoreWriter)) -> CoreIOEnv (a, CoreWriter)
    forall a b.
    IOEnv CoreReader a
    -> (a -> IOEnv CoreReader b) -> IOEnv CoreReader b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (\a
    x -> a -> CoreIOEnv (a, CoreWriter)
    forall a. a -> CoreIOEnv (a, CoreWriter)
    nop a
    x))

    instance MonadIO CoreM where
        liftIO :: forall a. IO a -> CoreM a
    liftIO = CoreIOEnv a -> CoreM a
    forall a. CoreIOEnv a -> CoreM a
    liftIOEnv (CoreIOEnv a -> CoreM a)
    -> (IO a -> CoreIOEnv a) -> IO a -> CoreM a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IO a -> CoreIOEnv a
    forall a. IO a -> IOEnv CoreReader a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    IOEnv.liftIO

    -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
    liftIOWithCount :: IO (SimplCount, a) -> CoreM a
    liftIOWithCount :: forall a. IO (SimplCount, a) -> CoreM a
    liftIOWithCount IO (SimplCount, a)
    what = IO (SimplCount, a) -> CoreM (SimplCount, a)
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO (SimplCount, a)
    what CoreM (SimplCount, a) -> ((SimplCount, a) -> CoreM a) -> CoreM a
    forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (\(SimplCount
    count, a
    x) -> SimplCount -> CoreM ()
    addSimplCount SimplCount
    count CoreM () -> CoreM a -> CoreM a
    forall a b. CoreM a -> CoreM b -> CoreM b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> a -> CoreM a
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x)

    {-
    ************************************************************************
    *                                                                      *
                 Reader, writer and state accessors
    *                                                                      *
    ************************************************************************
    -}

    getHscEnv :: CoreM HscEnv
    getHscEnv :: CoreM HscEnv
    getHscEnv = (CoreReader -> HscEnv) -> CoreM HscEnv
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> HscEnv
    cr_hsc_env

    getHomeRuleBase :: CoreM RuleBase
    getHomeRuleBase :: CoreM RuleBase
    getHomeRuleBase = (CoreReader -> RuleBase) -> CoreM RuleBase
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> RuleBase
    cr_rule_base

    initRuleEnv :: ModGuts -> CoreM RuleEnv
    initRuleEnv :: ModGuts -> CoreM RuleEnv
    initRuleEnv ModGuts
    guts
      = do { RuleBase
    hpt_rules <- CoreM RuleBase
    getHomeRuleBase
           ; RuleBase
    eps_rules <- CoreM RuleBase
    getExternalRuleBase
           ; RuleEnv -> CoreM RuleEnv
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ModGuts -> RuleBase -> RuleBase -> RuleEnv
    mkRuleEnv ModGuts
    guts RuleBase
    eps_rules RuleBase
    hpt_rules) }

    getExternalRuleBase :: CoreM RuleBase
    getExternalRuleBase :: CoreM RuleBase
    getExternalRuleBase = ExternalPackageState -> RuleBase
    eps_rule_base (ExternalPackageState -> RuleBase)
    -> CoreM ExternalPackageState -> CoreM RuleBase
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> CoreM ExternalPackageState
    get_eps

    getNamePprCtx :: CoreM NamePprCtx
    getNamePprCtx :: CoreM NamePprCtx
    getNamePprCtx = (CoreReader -> NamePprCtx) -> CoreM NamePprCtx
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> NamePprCtx
    cr_name_ppr_ctx

    getSrcSpanM :: CoreM SrcSpan
    getSrcSpanM :: CoreM SrcSpan
    getSrcSpanM = (CoreReader -> SrcSpan) -> CoreM SrcSpan
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> SrcSpan
    cr_loc

    addSimplCount :: SimplCount -> CoreM ()
    addSimplCount :: SimplCount -> CoreM ()
    addSimplCount SimplCount
    count = CoreWriter -> CoreM ()
    write (CoreWriter { cw_simpl_count :: SimplCount
    cw_simpl_count = SimplCount
    count })

    getUniqMask :: CoreM Char
    getUniqMask :: CoreM Char
    getUniqMask = (CoreReader -> Char) -> CoreM Char
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> Char
    cr_uniq_mask

    -- Convenience accessors for useful fields of HscEnv

    -- | Adjust the dyn flags passed to the argument action
    mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a
    mapDynFlagsCoreM :: forall a. (DynFlags -> DynFlags) -> CoreM a -> CoreM a
    mapDynFlagsCoreM DynFlags -> DynFlags
    f CoreM a
    m = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
    -> CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a b. (a -> b) -> a -> b
    $ do
      !CoreReader
    e <- IOEnv CoreReader CoreReader
    forall env. IOEnv env env
    getEnv
      let !e' :: CoreReader
    e' = CoreReader
    e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e }
      IO (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
    forall a. IO a -> IOEnv CoreReader a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (a, CoreWriter) -> CoreIOEnv (a, CoreWriter))
    -> IO (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
    forall a b. (a -> b) -> a -> b
    $ CoreReader -> CoreIOEnv (a, CoreWriter) -> IO (a, CoreWriter)
    forall env a. env -> IOEnv env a -> IO a
    runIOEnv CoreReader
    e' (CoreIOEnv (a, CoreWriter) -> IO (a, CoreWriter))
    -> CoreIOEnv (a, CoreWriter) -> IO (a, CoreWriter)
    forall a b. (a -> b) -> a -> b
    $! CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM CoreM a
    m

    -- | Drop the single count of the argument action so it doesn't effect
    -- the total.
    dropSimplCount :: CoreM a -> CoreM a
    dropSimplCount :: forall a. CoreM a -> CoreM a
    dropSimplCount CoreM a
    m = CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
    CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
    -> CoreIOEnv (a, CoreWriter) -> CoreM a
    forall a b. (a -> b) -> a -> b
    $ do
      (a
    a, CoreWriter
    _) <- CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM CoreM a
    m
      CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
    unCoreM (CoreM a -> CoreIOEnv (a, CoreWriter))
    -> CoreM a -> CoreIOEnv (a, CoreWriter)
    forall a b. (a -> b) -> a -> b
    $ a -> CoreM a
    forall a. a -> CoreM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    a

    instance HasDynFlags CoreM where
        getDynFlags :: CoreM DynFlags
    getDynFlags = (HscEnv -> DynFlags) -> CoreM HscEnv -> CoreM DynFlags
    forall a b. (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap HscEnv -> DynFlags
    hsc_dflags CoreM HscEnv
    getHscEnv

    instance HasLogger CoreM where
        getLogger :: CoreM Logger
    getLogger = (HscEnv -> Logger) -> CoreM HscEnv -> CoreM Logger
    forall a b. (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap HscEnv -> Logger
    hsc_logger CoreM HscEnv
    getHscEnv

    instance HasModule CoreM where
        getModule :: CoreM Module
    getModule = (CoreReader -> Module) -> CoreM Module
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> Module
    cr_module

    getInteractiveContext :: CoreM InteractiveContext
    getInteractiveContext :: CoreM InteractiveContext
    getInteractiveContext = HscEnv -> InteractiveContext
    hsc_IC (HscEnv -> InteractiveContext)
    -> CoreM HscEnv -> CoreM InteractiveContext
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> CoreM HscEnv
    getHscEnv

    getPackageFamInstEnv :: CoreM PackageFamInstEnv
    getPackageFamInstEnv :: CoreM PackageFamInstEnv
    getPackageFamInstEnv = ExternalPackageState -> PackageFamInstEnv
    eps_fam_inst_env (ExternalPackageState -> PackageFamInstEnv)
    -> CoreM ExternalPackageState -> CoreM PackageFamInstEnv
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> CoreM ExternalPackageState
    get_eps

    get_eps :: CoreM ExternalPackageState
    get_eps :: CoreM ExternalPackageState
    get_eps = do
        HscEnv
    hsc_env <- CoreM HscEnv
    getHscEnv
        IO ExternalPackageState -> CoreM ExternalPackageState
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ExternalPackageState -> CoreM ExternalPackageState)
    -> IO ExternalPackageState -> CoreM ExternalPackageState
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> IO ExternalPackageState
    hscEPS HscEnv
    hsc_env

    {-
    ************************************************************************
    *                                                                      *
                 Dealing with annotations
    *                                                                      *
    ************************************************************************
    -}

    -- | Get all annotations of a given type. This happens lazily, that is
    -- no deserialization will take place until the [a] is actually demanded and
    -- the [a] can also be empty (the UniqFM is not filtered).
    --
    -- This should be done once at the start of a Core-to-Core pass that uses
    -- annotations.
    --
    -- See Note [Annotations]
    getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    getAnnotations :: forall a.
    Typeable a =>
    ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    getAnnotations [Word8] -> a
    deserialize ModGuts
    guts = do
         HscEnv
    hsc_env <- CoreM HscEnv
    getHscEnv
         AnnEnv
    ann_env <- IO AnnEnv -> CoreM AnnEnv
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO AnnEnv -> CoreM AnnEnv) -> IO AnnEnv -> CoreM AnnEnv
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> Maybe ModGuts -> IO AnnEnv
    prepareAnnotations HscEnv
    hsc_env (ModGuts -> Maybe ModGuts
    forall a. a -> Maybe a
    Just ModGuts
    guts)
         (ModuleEnv [a], NameEnv [a]) -> CoreM (ModuleEnv [a], NameEnv [a])
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
    forall a.
    Typeable a =>
    ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
    deserializeAnns [Word8] -> a
    deserialize AnnEnv
    ann_env)

    -- | Get at most one annotation of a given type per annotatable item.
    getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
    getFirstAnnotations :: forall a.
    Typeable a =>
    ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
    getFirstAnnotations [Word8] -> a
    deserialize ModGuts
    guts
      = (ModuleEnv [a] -> ModuleEnv a)
    -> (NameEnv [a] -> NameEnv a)
    -> (ModuleEnv [a], NameEnv [a])
    -> (ModuleEnv a, NameEnv a)
    forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
    forall (p :: * -> * -> *) a b c d.
    Bifunctor p =>
    (a -> b) -> (c -> d) -> p a c -> p b d
    bimap ModuleEnv [a] -> ModuleEnv a
    forall {b}. ModuleEnv [b] -> ModuleEnv b
    mod NameEnv [a] -> NameEnv a
    forall {b}. NameEnv [b] -> NameEnv b
    name ((ModuleEnv [a], NameEnv [a]) -> (ModuleEnv a, NameEnv a))
    -> CoreM (ModuleEnv [a], NameEnv [a])
    -> CoreM (ModuleEnv a, NameEnv a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    forall a.
    Typeable a =>
    ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    getAnnotations [Word8] -> a
    deserialize ModGuts
    guts
      where
        mod :: ModuleEnv [b] -> ModuleEnv b
    mod = (Module -> [b] -> Maybe b) -> ModuleEnv [b] -> ModuleEnv b
    forall a b. (Module -> a -> Maybe b) -> ModuleEnv a -> ModuleEnv b
    mapMaybeModuleEnv (([b] -> Maybe b) -> Module -> [b] -> Maybe b
    forall a b. a -> b -> a
    const [b] -> Maybe b
    forall a. [a] -> Maybe a
    listToMaybe)
        name :: NameEnv [b] -> NameEnv b
    name = ([b] -> Maybe b) -> NameEnv [b] -> NameEnv b
    forall a b. (a -> Maybe b) -> NameEnv a -> NameEnv b
    mapMaybeNameEnv [b] -> Maybe b
    forall a. [a] -> Maybe a
    listToMaybe

    {-
    Note [Annotations]
    ~~~~~~~~~~~~~~~~~~
    A Core-to-Core pass that wants to make use of annotations calls
    getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
    annotations of a specific type. This produces all annotations from interface
    files read so far. However, annotations from interface files read during the
    pass will not be visible until getAnnotations is called again. This is similar
    to how rules work and probably isn't too bad.

    The current implementation could be optimised a bit: when looking up
    annotations for a thing from the HomePackageTable, we could search directly in
    the module where the thing is defined rather than building one UniqFM which
    contains all annotations we know of. This would work because annotations can
    only be given to things defined in the same module. However, since we would
    only want to deserialise every annotation once, we would have to build a cache
    for every module in the HTP. In the end, it's probably not worth it as long as
    we aren't using annotations heavily.

    ************************************************************************
    *                                                                      *
                    Direct screen output
    *                                                                      *
    ************************************************************************
    -}

    msg :: MessageClass -> SDoc -> CoreM ()
    msg :: MessageClass -> SDoc -> CoreM ()
    msg MessageClass
    msg_class SDoc
    doc = do
        Logger
    logger <- CoreM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
        SrcSpan
    loc    <- CoreM SrcSpan
    getSrcSpanM
        NamePprCtx
    name_ppr_ctx <- CoreM NamePprCtx
    getNamePprCtx
        let sty :: PprStyle
    sty = case MessageClass
    msg_class of
                    MCDiagnostic Severity
    _ DiagnosticReason
    _ Maybe DiagnosticCode
    _ -> PprStyle
    err_sty
                    MessageClass
    MCDump             -> PprStyle
    dump_sty
                    MessageClass
    _                  -> PprStyle
    user_sty
            err_sty :: PprStyle
    err_sty  = NamePprCtx -> PprStyle
    mkErrStyle NamePprCtx
    name_ppr_ctx
            user_sty :: PprStyle
    user_sty = NamePprCtx -> Depth -> PprStyle
    mkUserStyle NamePprCtx
    name_ppr_ctx Depth
    AllTheWay
            dump_sty :: PprStyle
    dump_sty = NamePprCtx -> PprStyle
    mkDumpStyle NamePprCtx
    name_ppr_ctx
        IO () -> CoreM ()
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    msg_class SrcSpan
    loc (PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    sty SDoc
    doc)

    -- | Output a String message to the screen
    putMsgS :: String -> CoreM ()
    putMsgS :: String -> CoreM ()
    putMsgS = SDoc -> CoreM ()
    putMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> SDoc
    forall doc. IsLine doc => String -> doc
    text

    -- | Output a message to the screen
    putMsg :: SDoc -> CoreM ()
    putMsg :: SDoc -> CoreM ()
    putMsg = MessageClass -> SDoc -> CoreM ()
    msg MessageClass
    MCInfo

    -- | Output an error to the screen. Does not cause the compiler to die.
    errorMsg :: SDoc -> CoreM ()
    errorMsg :: SDoc -> CoreM ()
    errorMsg SDoc
    doc = MessageClass -> SDoc -> CoreM ()
    msg MessageClass
    errorDiagnostic SDoc
    doc

    -- | Output a fatal error to the screen. Does not cause the compiler to die.
    fatalErrorMsgS :: String -> CoreM ()
    fatalErrorMsgS :: String -> CoreM ()
    fatalErrorMsgS = SDoc -> CoreM ()
    fatalErrorMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> SDoc
    forall doc. IsLine doc => String -> doc
    text

    -- | Output a fatal error to the screen. Does not cause the compiler to die.
    fatalErrorMsg :: SDoc -> CoreM ()
    fatalErrorMsg :: SDoc -> CoreM ()
    fatalErrorMsg = MessageClass -> SDoc -> CoreM ()
    msg MessageClass
    MCFatal

    -- | Output a string debugging message at verbosity level of @-v@ or higher
    debugTraceMsgS :: String -> CoreM ()
    debugTraceMsgS :: String -> CoreM ()
    debugTraceMsgS = SDoc -> CoreM ()
    debugTraceMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> SDoc
    forall doc. IsLine doc => String -> doc
    text

    -- | Outputs a debugging message at verbosity level of @-v@ or higher
    debugTraceMsg :: SDoc -> CoreM ()
    debugTraceMsg :: SDoc -> CoreM ()
    debugTraceMsg = MessageClass -> SDoc -> CoreM ()
    msg MessageClass
    MCDump