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

    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveFunctor #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

    module GHC.Core.Opt.Monad (
        -- * Configuration of the core-to-core passes
        CoreToDo(..), runWhen, runMaybe,
        SimplMode(..),
        FloatOutSwitches(..),
        pprPassDetails,

        -- * Plugins
        CorePluginPass, bindsOnlyPass,

        -- * Counting
        SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
        pprSimplCount, plusSimplCount, zeroSimplCount,
        isZeroSimplCount, hasDetailedCounts, Tick(..),

        -- * The monad
        CoreM, runCoreM,

        -- ** Reading from the monad
        getHscEnv, getRuleBase, getModule,
        getDynFlags, getPackageFamInstEnv,
        getVisibleOrphanMods, getUniqMask,
        getPrintUnqualified, getSrcSpanM,

        -- ** Writing to the monad
        addSimplCount,

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

        -- ** Dealing with annotations
        getAnnotations, getFirstAnnotations,

        -- ** Screen output
        putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
        fatalErrorMsg, fatalErrorMsgS,
        debugTraceMsg, debugTraceMsgS,
        dumpIfSet_dyn
      ) where

    import GHC.Prelude hiding ( read )

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

    import GHC.Core
    import GHC.Core.Unfold

    import GHC.Types.Basic  ( CompilerPhase(..) )
    import GHC.Types.Annotations
    import GHC.Types.Var
    import GHC.Types.Unique.Supply
    import GHC.Types.Name.Env
    import GHC.Types.SrcLoc

    import GHC.Utils.Outputable as Outputable
    import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger )
    import GHC.Utils.Error ( Severity(..) )
    import GHC.Utils.Monad

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

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

    import Data.Bifunctor ( bimap )
    import Data.List (intersperse, groupBy, sortBy)
    import Data.Ord
    import Data.Dynamic
    import Data.Map (Map)
    import qualified Data.Map as Map
    import qualified Data.Map.Strict as MapStrict
    import Data.Word
    import Control.Monad
    import Control.Applicative ( Alternative(..) )
    import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)

    {-
    ************************************************************************
    *                                                                      *
                  The CoreToDo type and related types
              Abstraction of core-to-core passes to run.
    *                                                                      *
    ************************************************************************
    -}

    data CoreToDo           -- These are diff core-to-core passes,
                            -- which may be invoked in any order,
                            -- as many times as you like.

      = CoreDoSimplify      -- The core-to-core simplifier.
            Int                    -- Max iterations
            SimplMode
      | CoreDoPluginPass String CorePluginPass
      | CoreDoFloatInwards
      | CoreDoFloatOutwards FloatOutSwitches
      | CoreLiberateCase
      | CoreDoPrintCore
      | CoreDoStaticArgs
      | CoreDoCallArity
      | CoreDoExitify
      | CoreDoDemand
      | CoreDoCpr
      | CoreDoWorkerWrapper
      | CoreDoSpecialising
      | CoreDoSpecConstr
      | CoreCSE
      | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                               -- matching this string
      | CoreDoNothing                -- Useful when building up
      | CoreDoPasses [CoreToDo]      -- lists of these things

      | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
      | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
                           --                 Core output, and hence useful to pass to endPass

      | CoreTidy
      | CorePrep
      | CoreAddCallerCcs
      | CoreOccurAnal

    instance Outputable CoreToDo where
      ppr :: CoreToDo -> SDoc
    ppr (CoreDoSimplify Int
    _ SimplMode
    _)     = String -> SDoc
    text String
    "Simplifier"
      ppr (CoreDoPluginPass String
    s CorePluginPass
    _)   = String -> SDoc
    text String
    "Core plugin: " SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    s
      ppr CoreToDo
    CoreDoFloatInwards       = String -> SDoc
    text String
    "Float inwards"
      ppr (CoreDoFloatOutwards FloatOutSwitches
    f)  = String -> SDoc
    text String
    "Float out" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (FloatOutSwitches -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatOutSwitches
    f)
      ppr CoreToDo
    CoreLiberateCase         = String -> SDoc
    text String
    "Liberate case"
      ppr CoreToDo
    CoreDoStaticArgs         = String -> SDoc
    text String
    "Static argument"
      ppr CoreToDo
    CoreDoCallArity          = String -> SDoc
    text String
    "Called arity analysis"
      ppr CoreToDo
    CoreDoExitify            = String -> SDoc
    text String
    "Exitification transformation"
      ppr CoreToDo
    CoreDoDemand             = String -> SDoc
    text String
    "Demand analysis"
      ppr CoreToDo
    CoreDoCpr                = String -> SDoc
    text String
    "Constructed Product Result analysis"
      ppr CoreToDo
    CoreDoWorkerWrapper      = String -> SDoc
    text String
    "Worker Wrapper binds"
      ppr CoreToDo
    CoreDoSpecialising       = String -> SDoc
    text String
    "Specialise"
      ppr CoreToDo
    CoreDoSpecConstr         = String -> SDoc
    text String
    "SpecConstr"
      ppr CoreToDo
    CoreCSE                  = String -> SDoc
    text String
    "Common sub-expression"
      ppr CoreToDo
    CoreDesugar              = String -> SDoc
    text String
    "Desugar (before optimization)"
      ppr CoreToDo
    CoreDesugarOpt           = String -> SDoc
    text String
    "Desugar (after optimization)"
      ppr CoreToDo
    CoreTidy                 = String -> SDoc
    text String
    "Tidy Core"
      ppr CoreToDo
    CoreAddCallerCcs         = String -> SDoc
    text String
    "Add caller cost-centres"
      ppr CoreToDo
    CorePrep                 = String -> SDoc
    text String
    "CorePrep"
      ppr CoreToDo
    CoreOccurAnal            = String -> SDoc
    text String
    "Occurrence analysis"
      ppr CoreToDo
    CoreDoPrintCore          = String -> SDoc
    text String
    "Print core"
      ppr (CoreDoRuleCheck {})     = String -> SDoc
    text String
    "Rule check"
      ppr CoreToDo
    CoreDoNothing            = String -> SDoc
    text String
    "CoreDoNothing"
      ppr (CoreDoPasses [CoreToDo]
    passes)    = String -> SDoc
    text String
    "CoreDoPasses" SDoc -> SDoc -> SDoc
    <+> [CoreToDo] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CoreToDo]
    passes

    pprPassDetails :: CoreToDo -> SDoc
    pprPassDetails :: CoreToDo -> SDoc
    pprPassDetails (CoreDoSimplify Int
    n SimplMode
    md) = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Max iterations =" SDoc -> SDoc -> SDoc
    <+> Int -> SDoc
    int Int
    n
                                                , SimplMode -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr SimplMode
    md ]
    pprPassDetails CoreToDo
    _ = SDoc
    Outputable.empty

    data SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad
      = SimplMode
            { SimplMode -> [String]
    sm_names        :: [String]       -- ^ Name(s) of the phase
            , SimplMode -> CompilerPhase
    sm_phase        :: CompilerPhase
            , SimplMode -> UnfoldingOpts
    sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options
            , SimplMode -> Bool
    sm_rules        :: !Bool          -- ^ Whether RULES are enabled
            , SimplMode -> Bool
    sm_inline       :: !Bool          -- ^ Whether inlining is enabled
            , SimplMode -> Bool
    sm_case_case    :: !Bool          -- ^ Whether case-of-case is enabled
            , SimplMode -> Bool
    sm_eta_expand   :: !Bool          -- ^ Whether eta-expansion is enabled
            , SimplMode -> Bool
    sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?
            , SimplMode -> Bool
    sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled
            , SimplMode -> Logger
    sm_logger       :: !Logger
            , SimplMode -> DynFlags
    sm_dflags       :: DynFlags
                -- Just for convenient non-monadic access; we don't override these.
                --
                -- Used for:
                --    - target platform (for `exprIsDupable` and `mkDupableAlt`)
                --    - Opt_DictsCheap and Opt_PedanticBottoms general flags
                --    - rules options (initRuleOpts)
                --    - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings
                --    - inlineCheck
            }

    instance Outputable SimplMode where
        ppr :: SimplMode -> SDoc
    ppr (SimplMode { sm_phase :: SimplMode -> CompilerPhase
    sm_phase = CompilerPhase
    p, sm_names :: SimplMode -> [String]
    sm_names = [String]
    ss
                       , sm_rules :: SimplMode -> Bool
    sm_rules = Bool
    r, sm_inline :: SimplMode -> Bool
    sm_inline = Bool
    i
                       , sm_cast_swizzle :: SimplMode -> Bool
    sm_cast_swizzle = Bool
    cs
                       , sm_eta_expand :: SimplMode -> Bool
    sm_eta_expand = Bool
    eta, sm_case_case :: SimplMode -> Bool
    sm_case_case = Bool
    cc })
           = String -> SDoc
    text String
    "SimplMode" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    braces (
             [SDoc] -> SDoc
    sep [ String -> SDoc
    text String
    "Phase =" SDoc -> SDoc -> SDoc
    <+> CompilerPhase -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CompilerPhase
    p SDoc -> SDoc -> SDoc
    <+>
                   SDoc -> SDoc
    brackets (String -> SDoc
    text ([String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    intersperse String
    "," [String]
    ss)) SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                 , Bool -> PtrString -> SDoc
    pp_flag Bool
    i   (String -> PtrString
    sLit String
    "inline") SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                 , Bool -> PtrString -> SDoc
    pp_flag Bool
    r   (String -> PtrString
    sLit String
    "rules") SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                 , Bool -> PtrString -> SDoc
    pp_flag Bool
    eta (String -> PtrString
    sLit String
    "eta-expand") SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                 , Bool -> PtrString -> SDoc
    pp_flag Bool
    cs  (String -> PtrString
    sLit String
    "cast-swizzle") SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                 , Bool -> PtrString -> SDoc
    pp_flag Bool
    cc  (String -> PtrString
    sLit String
    "case-of-case") ])
             where
               pp_flag :: Bool -> PtrString -> SDoc
    pp_flag Bool
    f PtrString
    s = Bool -> SDoc -> SDoc
    ppUnless Bool
    f (String -> SDoc
    text String
    "no") SDoc -> SDoc -> SDoc
    <+> PtrString -> SDoc
    ptext PtrString
    s

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

    -- The core-to-core pass ordering is derived from the DynFlags:
    runWhen :: Bool -> CoreToDo -> CoreToDo
    runWhen :: Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    True  CoreToDo
    do_this = CoreToDo
    do_this
    runWhen Bool
    False CoreToDo
    _       = CoreToDo
    CoreDoNothing

    runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
    runMaybe :: forall a. Maybe a -> (a -> CoreToDo) -> CoreToDo
    runMaybe (Just a
    x) a -> CoreToDo
    f = a -> CoreToDo
    f a
    x
    runMaybe Maybe a
    Nothing  a -> CoreToDo
    _ = CoreToDo
    CoreDoNothing

    {-

    ************************************************************************
    *                                                                      *
                 Types for Plugins
    *                                                                      *
    ************************************************************************
    -}

    -- | A description of the plugin pass itself
    type CorePluginPass = ModGuts -> CoreM ModGuts

    bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
    bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> CorePluginPass
    bindsOnlyPass CoreProgram -> CoreM CoreProgram
    pass ModGuts
    guts
      = do { CoreProgram
    binds' <- CoreProgram -> CoreM CoreProgram
    pass (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts)
           ; CorePluginPass
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ModGuts
    guts { mg_binds :: CoreProgram
    mg_binds = CoreProgram
    binds' }) }

    {-
    ************************************************************************
    *                                                                      *
                 Counting and logging
    *                                                                      *
    ************************************************************************
    -}

    getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
    getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
    getVerboseSimplStats = (Bool -> SDoc) -> SDoc
    getPprDebug          -- For now, anyway

    zeroSimplCount     :: DynFlags -> SimplCount
    isZeroSimplCount   :: SimplCount -> Bool
    hasDetailedCounts  :: SimplCount -> Bool
    pprSimplCount      :: SimplCount -> SDoc
    doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
    doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
    plusSimplCount     :: SimplCount -> SimplCount -> SimplCount

    data SimplCount
       = VerySimplCount !Int        -- Used when don't want detailed stats

       | SimplCount {
            SimplCount -> Int
    ticks   :: !Int,        -- Total ticks
            SimplCount -> TickCounts
    details :: !TickCounts, -- How many of each type

            SimplCount -> Int
    n_log   :: !Int,        -- N
            SimplCount -> [Tick]
    log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
                                    --   most recent first
            SimplCount -> [Tick]
    log2    :: [Tick]       -- Last opt_HistorySize events before that
                                    -- Having log1, log2 lets us accumulate the
                                    -- recent history reasonably efficiently
         }

    type TickCounts = Map Tick Int

    simplCountN :: SimplCount -> Int
    simplCountN :: SimplCount -> Int
    simplCountN (VerySimplCount Int
    n)         = Int
    n
    simplCountN (SimplCount { ticks :: SimplCount -> Int
    ticks = Int
    n }) = Int
    n

    zeroSimplCount :: DynFlags -> SimplCount
    zeroSimplCount DynFlags
    dflags
                    -- This is where we decide whether to do
                    -- the VerySimpl version or the full-stats version
      | DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_simpl_stats DynFlags
    dflags
      = SimplCount {ticks :: Int
    ticks = Int
    0, details :: TickCounts
    details = TickCounts
    forall k a. Map k a
    Map.empty,
                    n_log :: Int
    n_log = Int
    0, log1 :: [Tick]
    log1 = [], log2 :: [Tick]
    log2 = []}
      | Bool
    otherwise
      = Int -> SimplCount
    VerySimplCount Int
    0

    isZeroSimplCount :: SimplCount -> Bool
    isZeroSimplCount (VerySimplCount Int
    n)         = Int
    nInt -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Int
    0
    isZeroSimplCount (SimplCount { ticks :: SimplCount -> Int
    ticks = Int
    n }) = Int
    nInt -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Int
    0

    hasDetailedCounts :: SimplCount -> Bool
    hasDetailedCounts (VerySimplCount {}) = Bool
    False
    hasDetailedCounts (SimplCount {})     = Bool
    True

    doFreeSimplTick :: Tick -> SimplCount -> SimplCount
    doFreeSimplTick Tick
    tick sc :: SimplCount
    sc@SimplCount { details :: SimplCount -> TickCounts
    details = TickCounts
    dts }
      = SimplCount
    sc { details :: TickCounts
    details = TickCounts
    dts TickCounts -> Tick -> TickCounts
    `addTick` Tick
    tick }
    doFreeSimplTick Tick
    _ SimplCount
    sc = SimplCount
    sc

    doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
    doSimplTick DynFlags
    dflags Tick
    tick
        sc :: SimplCount
    sc@(SimplCount { ticks :: SimplCount -> Int
    ticks = Int
    tks, details :: SimplCount -> TickCounts
    details = TickCounts
    dts, n_log :: SimplCount -> Int
    n_log = Int
    nl, log1 :: SimplCount -> [Tick]
    log1 = [Tick]
    l1 })
      | Int
    nl Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= DynFlags -> Int
    historySize DynFlags
    dflags = SimplCount
    sc1 { n_log :: Int
    n_log = Int
    1, log1 :: [Tick]
    log1 = [Tick
    tick], log2 :: [Tick]
    log2 = [Tick]
    l1 }
      | Bool
    otherwise                = SimplCount
    sc1 { n_log :: Int
    n_log = Int
    nlInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1, log1 :: [Tick]
    log1 = Tick
    tick Tick -> [Tick] -> [Tick]
    forall a. a -> [a] -> [a]
    : [Tick]
    l1 }
      where
        sc1 :: SimplCount
    sc1 = SimplCount
    sc { ticks :: Int
    ticks = Int
    tksInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1, details :: TickCounts
    details = TickCounts
    dts TickCounts -> Tick -> TickCounts
    `addTick` Tick
    tick }

    doSimplTick DynFlags
    _ Tick
    _ (VerySimplCount Int
    n) = Int -> SimplCount
    VerySimplCount (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1)

    addTick :: TickCounts -> Tick -> TickCounts
    addTick :: TickCounts -> Tick -> TickCounts
    addTick TickCounts
    fm Tick
    tick = (Int -> Int -> Int) -> Tick -> Int -> TickCounts -> TickCounts
    forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
    MapStrict.insertWith Int -> Int -> Int
    forall a. Num a => a -> a -> a
    (+) Tick
    tick Int
    1 TickCounts
    fm

    plusSimplCount :: SimplCount -> SimplCount -> SimplCount
    plusSimplCount sc1 :: SimplCount
    sc1@(SimplCount { ticks :: SimplCount -> Int
    ticks = Int
    tks1, details :: SimplCount -> TickCounts
    details = TickCounts
    dts1 })
                   sc2 :: SimplCount
    sc2@(SimplCount { ticks :: SimplCount -> Int
    ticks = Int
    tks2, details :: SimplCount -> TickCounts
    details = TickCounts
    dts2 })
      = SimplCount
    log_base { ticks :: Int
    ticks = Int
    tks1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    tks2
                 , details :: TickCounts
    details = (Int -> Int -> Int) -> TickCounts -> TickCounts -> TickCounts
    forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
    MapStrict.unionWith Int -> Int -> Int
    forall a. Num a => a -> a -> a
    (+) TickCounts
    dts1 TickCounts
    dts2 }
      where
            -- A hackish way of getting recent log info
        log_base :: SimplCount
    log_base | [Tick] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (SimplCount -> [Tick]
    log1 SimplCount
    sc2) = SimplCount
    sc1    -- Nothing at all in sc2
                 | [Tick] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (SimplCount -> [Tick]
    log2 SimplCount
    sc2) = SimplCount
    sc2 { log2 :: [Tick]
    log2 = SimplCount -> [Tick]
    log1 SimplCount
    sc1 }
                 | Bool
    otherwise       = SimplCount
    sc2

    plusSimplCount (VerySimplCount Int
    n) (VerySimplCount Int
    m) = Int -> SimplCount
    VerySimplCount (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    m)
    plusSimplCount SimplCount
    lhs                SimplCount
    rhs                =
      GhcException -> SimplCount
    forall a. GhcException -> a
    throwGhcException (GhcException -> SimplCount)
    -> (SDoc -> GhcException) -> SDoc -> SimplCount
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> SDoc -> GhcException
    PprProgramError String
    "plusSimplCount" (SDoc -> SimplCount) -> SDoc -> SimplCount
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
        [ String -> SDoc
    text String
    "lhs"
        , SimplCount -> SDoc
    pprSimplCount SimplCount
    lhs
        , String -> SDoc
    text String
    "rhs"
        , SimplCount -> SDoc
    pprSimplCount SimplCount
    rhs
        ]
           -- We use one or the other consistently

    pprSimplCount :: SimplCount -> SDoc
    pprSimplCount (VerySimplCount Int
    n) = String -> SDoc
    text String
    "Total ticks:" SDoc -> SDoc -> SDoc
    <+> Int -> SDoc
    int Int
    n
    pprSimplCount (SimplCount { ticks :: SimplCount -> Int
    ticks = Int
    tks, details :: SimplCount -> TickCounts
    details = TickCounts
    dts, log1 :: SimplCount -> [Tick]
    log1 = [Tick]
    l1, log2 :: SimplCount -> [Tick]
    log2 = [Tick]
    l2 })
      = [SDoc] -> SDoc
    vcat [String -> SDoc
    text String
    "Total ticks:    " SDoc -> SDoc -> SDoc
    <+> Int -> SDoc
    int Int
    tks,
              SDoc
    blankLine,
              TickCounts -> SDoc
    pprTickCounts TickCounts
    dts,
              (Bool -> SDoc) -> SDoc
    getVerboseSimplStats ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
    forall a b. (a -> b) -> a -> b
    $ \Bool
    dbg -> if Bool
    dbg
              then
                    [SDoc] -> SDoc
    vcat [SDoc
    blankLine,
                          String -> SDoc
    text String
    "Log (most recent first)",
                          Int -> SDoc -> SDoc
    nest Int
    4 ([SDoc] -> SDoc
    vcat ((Tick -> SDoc) -> [Tick] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Tick -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Tick]
    l1) SDoc -> SDoc -> SDoc
    $$ [SDoc] -> SDoc
    vcat ((Tick -> SDoc) -> [Tick] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Tick -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Tick]
    l2))]
              else SDoc
    Outputable.empty
        ]

    {- Note [Which transformations are innocuous]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    At one point (Jun 18) I wondered if some transformations (ticks)
    might be  "innocuous", in the sense that they do not unlock a later
    transformation that does not occur in the same pass.  If so, we could
    refrain from bumping the overall tick-count for such innocuous
    transformations, and perhaps terminate the simplifier one pass
    earlier.

    But alas I found that virtually nothing was innocuous!  This Note
    just records what I learned, in case anyone wants to try again.

    These transformations are not innocuous:

    *** NB: I think these ones could be made innocuous
              EtaExpansion
              LetFloatFromLet

    LetFloatFromLet
        x = K (let z = e2 in Just z)
      prepareRhs transforms to
        x2 = let z=e2 in Just z
        x  = K xs
      And now more let-floating can happen in the
      next pass, on x2

    PreInlineUnconditionally
      Example in spectral/cichelli/Auxil
         hinsert = ...let lo = e in
                      let j = ...lo... in
                      case x of
                        False -> ()
                        True -> case lo of I# lo' ->
                                  ...j...
      When we PreInlineUnconditionally j, lo's occ-info changes to once,
      so it can be PreInlineUnconditionally in the next pass, and a
      cascade of further things can happen.

    PostInlineUnconditionally
      let x = e in
      let y = ...x.. in
      case .. of { A -> ...x...y...
                   B -> ...x...y... }
      Current postinlineUnconditinaly will inline y, and then x; sigh.

      But PostInlineUnconditionally might also unlock subsequent
      transformations for the same reason as PreInlineUnconditionally,
      so it's probably not innocuous anyway.

    KnownBranch, BetaReduction:
      May drop chunks of code, and thereby enable PreInlineUnconditionally
      for some let-binding which now occurs once

    EtaExpansion:
      Example in imaginary/digits-of-e1
        fail = \void. e          where e :: IO ()
      --> etaExpandRhs
        fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())
      --> Next iteration of simplify
        fail1 = \void. \s. (e |> g) s
        fail = fail1 |> Void# -> sym g
      And now inline 'fail'

    CaseMerge:
      case x of y {
        DEFAULT -> case y of z { pi -> ei }
        alts2 }
      ---> CaseMerge
        case x of { pi -> let z = y in ei
                  ; alts2 }
      The "let z=y" case-binder-swap gets dealt with in the next pass
    -}

    pprTickCounts :: Map Tick Int -> SDoc
    pprTickCounts :: TickCounts -> SDoc
    pprTickCounts TickCounts
    counts
      = [SDoc] -> SDoc
    vcat (([(Tick, Int)] -> SDoc) -> [[(Tick, Int)]] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map [(Tick, Int)] -> SDoc
    pprTickGroup [[(Tick, Int)]]
    groups)
      where
        groups :: [[(Tick,Int)]]    -- Each group shares a common tag
                                    -- toList returns common tags adjacent
        groups :: [[(Tick, Int)]]
    groups = ((Tick, Int) -> (Tick, Int) -> Bool)
    -> [(Tick, Int)] -> [[(Tick, Int)]]
    forall a. (a -> a -> Bool) -> [a] -> [[a]]
    groupBy (Tick, Int) -> (Tick, Int) -> Bool
    forall {b} {b}. (Tick, b) -> (Tick, b) -> Bool
    same_tag (TickCounts -> [(Tick, Int)]
    forall k a. Map k a -> [(k, a)]
    Map.toList TickCounts
    counts)
        same_tag :: (Tick, b) -> (Tick, b) -> Bool
    same_tag (Tick
    tick1,b
    _) (Tick
    tick2,b
    _) = Tick -> Int
    tickToTag Tick
    tick1 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Tick -> Int
    tickToTag Tick
    tick2

    pprTickGroup :: [(Tick, Int)] -> SDoc
    pprTickGroup :: [(Tick, Int)] -> SDoc
    pprTickGroup group :: [(Tick, Int)]
    group@((Tick
    tick1,Int
    _):[(Tick, Int)]
    _)
      = SDoc -> Int -> SDoc -> SDoc
    hang (Int -> SDoc
    int ([Int] -> Int
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [Int
    n | (Tick
    _,Int
    n) <- [(Tick, Int)]
    group]) SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text (Tick -> String
    tickString Tick
    tick1))
           Int
    2 ([SDoc] -> SDoc
    vcat [ Int -> SDoc
    int Int
    n SDoc -> SDoc -> SDoc
    <+> Tick -> SDoc
    pprTickCts Tick
    tick
                                        -- flip as we want largest first
                   | (Tick
    tick,Int
    n) <- ((Tick, Int) -> (Tick, Int) -> Ordering)
    -> [(Tick, Int)] -> [(Tick, Int)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (((Tick, Int) -> (Tick, Int) -> Ordering)
    -> (Tick, Int) -> (Tick, Int) -> Ordering
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (((Tick, Int) -> Int) -> (Tick, Int) -> (Tick, Int) -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing (Tick, Int) -> Int
    forall a b. (a, b) -> b
    snd)) [(Tick, Int)]
    group])
    pprTickGroup [] = String -> SDoc
    forall a. String -> a
    panic String
    "pprTickGroup"

    data Tick  -- See Note [Which transformations are innocuous]
      = PreInlineUnconditionally    Id
      | PostInlineUnconditionally   Id

      | UnfoldingDone               Id
      | RuleFired                   FastString      -- Rule name

      | LetFloatFromLet
      | EtaExpansion                Id      -- LHS binder
      | EtaReduction                Id      -- Binder on outer lambda
      | BetaReduction               Id      -- Lambda binder

      | CaseOfCase                  Id      -- Bndr on *inner* case
      | KnownBranch                 Id      -- Case binder
      | CaseMerge                   Id      -- Binder on outer case
      | AltMerge                    Id      -- Case binder
      | CaseElim                    Id      -- Case binder
      | CaseIdentity                Id      -- Case binder
      | FillInCaseDefault           Id      -- Case binder

      | SimplifierDone              -- Ticked at each iteration of the simplifier

    instance Outputable Tick where
      ppr :: Tick -> SDoc
    ppr Tick
    tick = String -> SDoc
    text (Tick -> String
    tickString Tick
    tick) SDoc -> SDoc -> SDoc
    <+> Tick -> SDoc
    pprTickCts Tick
    tick

    instance Eq Tick where
      Tick
    a == :: Tick -> Tick -> Bool
    == Tick
    b = case Tick
    a Tick -> Tick -> Ordering
    `cmpTick` Tick
    b of
               Ordering
    EQ -> Bool
    True
               Ordering
    _ -> Bool
    False

    instance Ord Tick where
      compare :: Tick -> Tick -> Ordering
    compare = Tick -> Tick -> Ordering
    cmpTick

    tickToTag :: Tick -> Int
    tickToTag :: Tick -> Int
    tickToTag (PreInlineUnconditionally Id
    _)  = Int
    0
    tickToTag (PostInlineUnconditionally Id
    _) = Int
    1
    tickToTag (UnfoldingDone Id
    _)             = Int
    2
    tickToTag (RuleFired FastString
    _)                 = Int
    3
    tickToTag Tick
    LetFloatFromLet               = Int
    4
    tickToTag (EtaExpansion Id
    _)              = Int
    5
    tickToTag (EtaReduction Id
    _)              = Int
    6
    tickToTag (BetaReduction Id
    _)             = Int
    7
    tickToTag (CaseOfCase Id
    _)                = Int
    8
    tickToTag (KnownBranch Id
    _)               = Int
    9
    tickToTag (CaseMerge Id
    _)                 = Int
    10
    tickToTag (CaseElim Id
    _)                  = Int
    11
    tickToTag (CaseIdentity Id
    _)              = Int
    12
    tickToTag (FillInCaseDefault Id
    _)         = Int
    13
    tickToTag Tick
    SimplifierDone                = Int
    16
    tickToTag (AltMerge Id
    _)                  = Int
    17

    tickString :: Tick -> String
    tickString :: Tick -> String
    tickString (PreInlineUnconditionally Id
    _) = String
    "PreInlineUnconditionally"
    tickString (PostInlineUnconditionally Id
    _)= String
    "PostInlineUnconditionally"
    tickString (UnfoldingDone Id
    _)            = String
    "UnfoldingDone"
    tickString (RuleFired FastString
    _)                = String
    "RuleFired"
    tickString Tick
    LetFloatFromLet              = String
    "LetFloatFromLet"
    tickString (EtaExpansion Id
    _)             = String
    "EtaExpansion"
    tickString (EtaReduction Id
    _)             = String
    "EtaReduction"
    tickString (BetaReduction Id
    _)            = String
    "BetaReduction"
    tickString (CaseOfCase Id
    _)               = String
    "CaseOfCase"
    tickString (KnownBranch Id
    _)              = String
    "KnownBranch"
    tickString (CaseMerge Id
    _)                = String
    "CaseMerge"
    tickString (AltMerge Id
    _)                 = String
    "AltMerge"
    tickString (CaseElim Id
    _)                 = String
    "CaseElim"
    tickString (CaseIdentity Id
    _)             = String
    "CaseIdentity"
    tickString (FillInCaseDefault Id
    _)        = String
    "FillInCaseDefault"
    tickString Tick
    SimplifierDone               = String
    "SimplifierDone"

    pprTickCts :: Tick -> SDoc
    pprTickCts :: Tick -> SDoc
    pprTickCts (PreInlineUnconditionally Id
    v) = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (PostInlineUnconditionally Id
    v)= Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (UnfoldingDone Id
    v)            = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (RuleFired FastString
    v)                = FastString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FastString
    v
    pprTickCts Tick
    LetFloatFromLet              = SDoc
    Outputable.empty
    pprTickCts (EtaExpansion Id
    v)             = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (EtaReduction Id
    v)             = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (BetaReduction Id
    v)            = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (CaseOfCase Id
    v)               = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (KnownBranch Id
    v)              = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (CaseMerge Id
    v)                = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (AltMerge Id
    v)                 = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (CaseElim Id
    v)                 = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (CaseIdentity Id
    v)             = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts (FillInCaseDefault Id
    v)        = Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v
    pprTickCts Tick
    _                            = SDoc
    Outputable.empty

    cmpTick :: Tick -> Tick -> Ordering
    cmpTick :: Tick -> Tick -> Ordering
    cmpTick Tick
    a Tick
    b = case (Tick -> Int
    tickToTag Tick
    a Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Tick -> Int
    tickToTag Tick
    b) of
                    Ordering
    GT -> Ordering
    GT
                    Ordering
    EQ -> Tick -> Tick -> Ordering
    cmpEqTick Tick
    a Tick
    b
                    Ordering
    LT -> Ordering
    LT

    cmpEqTick :: Tick -> Tick -> Ordering
    cmpEqTick :: Tick -> Tick -> Ordering
    cmpEqTick (PreInlineUnconditionally Id
    a)  (PreInlineUnconditionally Id
    b)    = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (PostInlineUnconditionally Id
    a) (PostInlineUnconditionally Id
    b)   = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (UnfoldingDone Id
    a)             (UnfoldingDone Id
    b)               = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (RuleFired FastString
    a)                 (RuleFired FastString
    b)                   = FastString
    a FastString -> FastString -> Ordering
    `uniqCompareFS` FastString
    b
    cmpEqTick (EtaExpansion Id
    a)              (EtaExpansion Id
    b)                = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (EtaReduction Id
    a)              (EtaReduction Id
    b)                = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (BetaReduction Id
    a)             (BetaReduction Id
    b)               = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (CaseOfCase Id
    a)                (CaseOfCase Id
    b)                  = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (KnownBranch Id
    a)               (KnownBranch Id
    b)                 = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (CaseMerge Id
    a)                 (CaseMerge Id
    b)                   = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (AltMerge Id
    a)                  (AltMerge Id
    b)                    = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (CaseElim Id
    a)                  (CaseElim Id
    b)                    = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (CaseIdentity Id
    a)              (CaseIdentity Id
    b)                = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick (FillInCaseDefault Id
    a)         (FillInCaseDefault Id
    b)           = Id
    a Id -> Id -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Id
    b
    cmpEqTick Tick
    _                             Tick
    _                               = Ordering
    EQ

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

    data CoreReader = CoreReader {
            CoreReader -> HscEnv
    cr_hsc_env             :: HscEnv,
            CoreReader -> RuleBase
    cr_rule_base           :: RuleBase,
            CoreReader -> Module
    cr_module              :: Module,
            CoreReader -> PrintUnqualified
    cr_print_unqual        :: PrintUnqualified,
            CoreReader -> SrcSpan
    cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
                                                 -- are at least tagged with the right source file
            CoreReader -> ModuleSet
    cr_visible_orphan_mods :: !ModuleSet,
            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 :: DynFlags -> CoreWriter
    emptyWriter :: DynFlags -> CoreWriter
    emptyWriter DynFlags
    dflags = CoreWriter {
            cw_simpl_count :: SimplCount
    cw_simpl_count = DynFlags -> SimplCount
    zeroSimplCount DynFlags
    dflags
        }

    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
    <$ :: forall a b. a -> CoreM b -> CoreM a
    $c<$ :: forall a b. a -> CoreM b -> CoreM a
    fmap :: forall a b. (a -> b) -> CoreM a -> CoreM b
    $cfmap :: forall a b. (a -> b) -> CoreM a -> CoreM b
    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 (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)
    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 (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 (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 (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 (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 (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
             -> ModuleSet
             -> PrintUnqualified
             -> SrcSpan
             -> CoreM a
             -> IO (a, SimplCount)
    runCoreM :: forall a.
    HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> ModuleSet
    -> PrintUnqualified
    -> SrcSpan
    -> CoreM a
    -> IO (a, SimplCount)
    runCoreM HscEnv
    hsc_env RuleBase
    rule_base Char
    mask Module
    mod ModuleSet
    orph_imps PrintUnqualified
    print_unqual 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_visible_orphan_mods :: ModuleSet
    cr_visible_orphan_mods = ModuleSet
    orph_imps,
                cr_print_unqual :: PrintUnqualified
    cr_print_unqual = PrintUnqualified
    print_unqual,
                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
        CoreReader
    r <- IOEnv CoreReader CoreReader
    forall env. IOEnv env env
    getEnv
        (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    x, DynFlags -> CoreWriter
    emptyWriter (DynFlags -> CoreWriter) -> DynFlags -> CoreWriter
    forall a b. (a -> b) -> a -> b
    $ (HscEnv -> DynFlags
    hsc_dflags (HscEnv -> DynFlags)
    -> (CoreReader -> HscEnv) -> CoreReader -> DynFlags
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreReader -> HscEnv
    cr_hsc_env) CoreReader
    r)

    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 (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 (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 (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 (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 (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO (SimplCount, a)
    what CoreM (SimplCount, a) -> ((SimplCount, a) -> CoreM a) -> CoreM a
    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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> 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

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

    getVisibleOrphanMods :: CoreM ModuleSet
    getVisibleOrphanMods :: CoreM ModuleSet
    getVisibleOrphanMods = (CoreReader -> ModuleSet) -> CoreM ModuleSet
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> ModuleSet
    cr_visible_orphan_mods

    getPrintUnqualified :: CoreM PrintUnqualified
    getPrintUnqualified :: CoreM PrintUnqualified
    getPrintUnqualified = (CoreReader -> PrintUnqualified) -> CoreM PrintUnqualified
    forall a. (CoreReader -> a) -> CoreM a
    read CoreReader -> PrintUnqualified
    cr_print_unqual

    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

    instance HasDynFlags CoreM where
        getDynFlags :: CoreM DynFlags
    getDynFlags = (HscEnv -> DynFlags) -> CoreM HscEnv -> CoreM DynFlags
    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 (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

    getPackageFamInstEnv :: CoreM PackageFamInstEnv
    getPackageFamInstEnv :: CoreM PackageFamInstEnv
    getPackageFamInstEnv = do
        HscEnv
    hsc_env <- CoreM HscEnv
    getHscEnv
        ExternalPackageState
    eps <- IO ExternalPackageState -> CoreM ExternalPackageState
    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
        PackageFamInstEnv -> CoreM PackageFamInstEnv
    forall (m :: * -> *) a. Monad m => a -> m a
    return (PackageFamInstEnv -> CoreM PackageFamInstEnv)
    -> PackageFamInstEnv -> CoreM PackageFamInstEnv
    forall a b. (a -> b) -> a -> b
    $ ExternalPackageState -> PackageFamInstEnv
    eps_fam_inst_env ExternalPackageState
    eps

    {-
    ************************************************************************
    *                                                                      *
                 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 (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 (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 (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 {elt2}. NameEnv [elt2] -> NameEnv elt2
    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 = ([b] -> b) -> ModuleEnv [b] -> ModuleEnv b
    forall a b. (a -> b) -> ModuleEnv a -> ModuleEnv b
    mapModuleEnv [b] -> b
    forall a. [a] -> a
    head (ModuleEnv [b] -> ModuleEnv b)
    -> (ModuleEnv [b] -> ModuleEnv [b]) -> ModuleEnv [b] -> ModuleEnv b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Module -> [b] -> Bool) -> ModuleEnv [b] -> ModuleEnv [b]
    forall a. (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
    filterModuleEnv (([b] -> Bool) -> Module -> [b] -> Bool
    forall a b. a -> b -> a
    const (([b] -> Bool) -> Module -> [b] -> Bool)
    -> ([b] -> Bool) -> Module -> [b] -> Bool
    forall a b. (a -> b) -> a -> b
    $ Bool -> Bool
    not (Bool -> Bool) -> ([b] -> Bool) -> [b] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [b] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null)
        name :: NameEnv [elt2] -> NameEnv elt2
    name = ([elt2] -> elt2) -> NameEnv [elt2] -> NameEnv elt2
    forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
    mapNameEnv [elt2] -> elt2
    forall a. [a] -> a
    head (NameEnv [elt2] -> NameEnv elt2)
    -> (NameEnv [elt2] -> NameEnv [elt2])
    -> NameEnv [elt2]
    -> NameEnv elt2
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([elt2] -> Bool) -> NameEnv [elt2] -> NameEnv [elt2]
    forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
    filterNameEnv (Bool -> Bool
    not (Bool -> Bool) -> ([elt2] -> Bool) -> [elt2] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [elt2] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null)

    {-
    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 :: Severity -> WarnReason -> SDoc -> CoreM ()
    msg :: Severity -> WarnReason -> SDoc -> CoreM ()
    msg Severity
    sev WarnReason
    reason SDoc
    doc = do
        DynFlags
    dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        Logger
    logger <- CoreM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
        SrcSpan
    loc    <- CoreM SrcSpan
    getSrcSpanM
        PrintUnqualified
    unqual <- CoreM PrintUnqualified
    getPrintUnqualified
        let sty :: PprStyle
    sty = case Severity
    sev of
                    Severity
    SevError   -> PprStyle
    err_sty
                    Severity
    SevWarning -> PprStyle
    err_sty
                    Severity
    SevDump    -> PprStyle
    dump_sty
                    Severity
    _          -> PprStyle
    user_sty
            err_sty :: PprStyle
    err_sty  = PrintUnqualified -> PprStyle
    mkErrStyle PrintUnqualified
    unqual
            user_sty :: PprStyle
    user_sty = PrintUnqualified -> Depth -> PprStyle
    mkUserStyle PrintUnqualified
    unqual Depth
    AllTheWay
            dump_sty :: PprStyle
    dump_sty = PrintUnqualified -> PprStyle
    mkDumpStyle PrintUnqualified
    unqual
        IO () -> CoreM ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    reason Severity
    sev 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
    text

    -- | Output a message to the screen
    putMsg :: SDoc -> CoreM ()
    putMsg :: SDoc -> CoreM ()
    putMsg = Severity -> WarnReason -> SDoc -> CoreM ()
    msg Severity
    SevInfo WarnReason
    NoReason

    -- | Output an error to the screen. Does not cause the compiler to die.
    errorMsgS :: String -> CoreM ()
    errorMsgS :: String -> CoreM ()
    errorMsgS = SDoc -> CoreM ()
    errorMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> SDoc
    text

    -- | Output an error to the screen. Does not cause the compiler to die.
    errorMsg :: SDoc -> CoreM ()
    errorMsg :: SDoc -> CoreM ()
    errorMsg = Severity -> WarnReason -> SDoc -> CoreM ()
    msg Severity
    SevError WarnReason
    NoReason

    warnMsg :: WarnReason -> SDoc -> CoreM ()
    warnMsg :: WarnReason -> SDoc -> CoreM ()
    warnMsg = Severity -> WarnReason -> SDoc -> CoreM ()
    msg Severity
    SevWarning

    -- | 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
    text

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

    -- | 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
    text

    -- | Outputs a debugging message at verbosity level of @-v@ or higher
    debugTraceMsg :: SDoc -> CoreM ()
    debugTraceMsg :: SDoc -> CoreM ()
    debugTraceMsg = Severity -> WarnReason -> SDoc -> CoreM ()
    msg Severity
    SevDump WarnReason
    NoReason

    -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
    dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()
    dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()
    dumpIfSet_dyn DumpFlag
    flag String
    str DumpFormat
    fmt SDoc
    doc = do
        DynFlags
    dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        Logger
    logger <- CoreM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
        PrintUnqualified
    unqual <- CoreM PrintUnqualified
    getPrintUnqualified
        Bool -> CoreM () -> CoreM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    flag DynFlags
    dflags) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> CoreM ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ do
            let sty :: PprStyle
    sty = PrintUnqualified -> PprStyle
    mkDumpStyle PrintUnqualified
    unqual
            Logger -> DumpAction
    putDumpMsg Logger
    logger DynFlags
    dflags PprStyle
    sty DumpFlag
    flag String
    str DumpFormat
    fmt SDoc
    doc