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

    A lint pass to check basic STG invariants:

    - Variables should be defined before used.

    - Let bindings should not have unboxed types (unboxed bindings should only
      appear in case), except when they're join points (see Note [Core let/app
      invariant] and #14117).

    - If linting after unarisation, invariants listed in Note [Post-unarisation
      invariants].

    Because we don't have types and coercions in STG we can't really check types
    here.

    Some history:

    StgLint used to check types, but it never worked and so it was disabled in 2000
    with this note:

        WARNING:
        ~~~~~~~~

        This module has suffered bit-rot; it is likely to yield lint errors
        for Stg code that is currently perfectly acceptable for code
        generation.  Solution: don't use it!  (KSW 2000-05).

    Since then there were some attempts at enabling it again, as summarised in #14787.
    It's finally decided that we remove all type checking and only look for
    basic properties listed above.
    -}

    {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
      DeriveFunctor #-}

    module GHC.Stg.Lint ( lintStgTopBindings ) where

    import GHC.Prelude

    import GHC.Stg.Syntax

    import GHC.Driver.Session
    import GHC.Core.Lint        ( interactiveInScope )
    import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
    import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )
    import GHC.Types.CostCentre ( isCurrentCCS )
    import GHC.Types.Id
    import GHC.Types.Var.Set
    import GHC.Core.DataCon
    import GHC.Core             ( AltCon(..) )
    import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
    import GHC.Utils.Error      ( Severity(..), mkLocMessage )
    import GHC.Core.Type
    import GHC.Types.RepType
    import GHC.Types.SrcLoc
    import GHC.Utils.Logger
    import GHC.Utils.Outputable
    import GHC.Unit.Module            ( Module )
    import GHC.Runtime.Context        ( InteractiveContext )
    import qualified GHC.Utils.Error as Err
    import Control.Applicative ((<|>))
    import Control.Monad

    lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                       => Logger
                       -> DynFlags
                       -> InteractiveContext
                       -> Module -- ^ module being compiled
                       -> Bool   -- ^ have we run Unarise yet?
                       -> String -- ^ who produced the STG?
                       -> [GenStgTopBinding a]
                       -> IO ()

    lintStgTopBindings :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    Logger
    -> DynFlags
    -> InteractiveContext
    -> Module
    -> Bool
    -> String
    -> [GenStgTopBinding a]
    -> IO ()
    lintStgTopBindings Logger
    logger DynFlags
    dflags InteractiveContext
    ictxt Module
    this_mod Bool
    unarised String
    whodunnit [GenStgTopBinding a]
    binds
      = {-# SCC "StgLint" #-}
        case Module -> Bool -> StgPprOpts -> IdSet -> LintM () -> Maybe SDoc
    forall a.
    Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
    initL Module
    this_mod Bool
    unarised StgPprOpts
    opts IdSet
    top_level_binds ([GenStgTopBinding a] -> LintM ()
    lint_binds [GenStgTopBinding a]
    binds) of
          Maybe SDoc
    Nothing  ->
            () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          Just SDoc
    msg -> do
            Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    Err.SevDump SrcSpan
    noSrcSpan
              (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle
              ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "*** Stg Lint ErrMsgs: in" SDoc -> SDoc -> SDoc
    <+>
                            String -> SDoc
    text String
    whodunnit SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "***",
                      SDoc
    msg,
                      String -> SDoc
    text String
    "*** Offending Program ***",
                      StgPprOpts -> [GenStgTopBinding a] -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> [GenStgTopBinding pass] -> SDoc
    pprGenStgTopBindings StgPprOpts
    opts [GenStgTopBinding a]
    binds,
                      String -> SDoc
    text String
    "*** End of Offense ***"])
            Logger -> DynFlags -> Int -> IO ()
    Err.ghcExit Logger
    logger DynFlags
    dflags Int
    1
      where
        opts :: StgPprOpts
    opts = DynFlags -> StgPprOpts
    initStgPprOpts DynFlags
    dflags
        -- Bring all top-level binds into scope because CoreToStg does not generate
        -- bindings in dependency order (so we may see a use before its definition).
        top_level_binds :: IdSet
    top_level_binds = IdSet -> [Id] -> IdSet
    extendVarSetList ([Id] -> IdSet
    mkVarSet ([GenStgTopBinding a] -> [Id]
    forall (a :: StgPass).
    (BinderP a ~ Id) =>
    [GenStgTopBinding a] -> [Id]
    bindersOfTopBinds [GenStgTopBinding a]
    binds))
                                           (InteractiveContext -> [Id]
    interactiveInScope InteractiveContext
    ictxt)

        lint_binds :: [GenStgTopBinding a] -> LintM ()

        lint_binds :: [GenStgTopBinding a] -> LintM ()
    lint_binds [] = () -> LintM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        lint_binds (GenStgTopBinding a
    bind:[GenStgTopBinding a]
    binds) = do
            [Id]
    binders <- GenStgTopBinding a -> LintM [Id]
    forall {a :: StgPass}.
    (BinderP a ~ Id, Outputable (XLet a), Outputable (XConApp a),
     Outputable (XLetNoEscape a), Outputable (XRhsClosure a),
     OutputableBndr (BinderP a)) =>
    GenStgTopBinding a -> LintM [Id]
    lint_bind GenStgTopBinding a
    bind
            [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    binders (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                [GenStgTopBinding a] -> LintM ()
    lint_binds [GenStgTopBinding a]
    binds

        lint_bind :: GenStgTopBinding a -> LintM [Id]
    lint_bind (StgTopLifted GenStgBinding a
    bind) = TopLevelFlag -> GenStgBinding a -> LintM [Id]
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> GenStgBinding a -> LintM [Id]
    lintStgBinds TopLevelFlag
    TopLevel GenStgBinding a
    bind
        lint_bind (StgTopStringLit Id
    v ByteString
    _) = [Id] -> LintM [Id]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Id
    v]

    lintStgArg :: StgArg -> LintM ()
    lintStgArg :: StgArg -> LintM ()
    lintStgArg (StgLitArg Literal
    _) = () -> LintM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    lintStgArg (StgVarArg Id
    v) = Id -> LintM ()
    lintStgVar Id
    v

    lintStgVar :: Id -> LintM ()
    lintStgVar :: Id -> LintM ()
    lintStgVar Id
    id = Id -> LintM ()
    checkInScope Id
    id

    lintStgBinds
        :: (OutputablePass a, BinderP a ~ Id)
        => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
    lintStgBinds :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> GenStgBinding a -> LintM [Id]
    lintStgBinds TopLevelFlag
    top_lvl (StgNonRec BinderP a
    binder GenStgRhs a
    rhs) = do
        TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
    lint_binds_help TopLevelFlag
    top_lvl (Id
    BinderP a
    binder,GenStgRhs a
    rhs)
        [Id] -> LintM [Id]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Id
    BinderP a
    binder]

    lintStgBinds TopLevelFlag
    top_lvl (StgRec [(BinderP a, GenStgRhs a)]
    pairs)
      = [Id] -> LintM [Id] -> LintM [Id]
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    binders (LintM [Id] -> LintM [Id]) -> LintM [Id] -> LintM [Id]
    forall a b. (a -> b) -> a -> b
    $ do
            ((Id, GenStgRhs a) -> LintM ()) -> [(Id, GenStgRhs a)] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
    lint_binds_help TopLevelFlag
    top_lvl) [(Id, GenStgRhs a)]
    [(BinderP a, GenStgRhs a)]
    pairs
            [Id] -> LintM [Id]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Id]
    binders
      where
        binders :: [Id]
    binders = [Id
    b | (Id
    b,GenStgRhs a
    _) <- [(Id, GenStgRhs a)]
    [(BinderP a, GenStgRhs a)]
    pairs]

    lint_binds_help
        :: (OutputablePass a, BinderP a ~ Id)
        => TopLevelFlag
        -> (Id, GenStgRhs a)
        -> LintM ()
    lint_binds_help :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
    lint_binds_help TopLevelFlag
    top_lvl (Id
    binder, GenStgRhs a
    rhs)
      = LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Id -> LintLocInfo
    RhsOf Id
    binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ do
            Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl) (GenStgRhs a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgRhs a -> LintM ()
    checkNoCurrentCCS GenStgRhs a
    rhs)
            GenStgRhs a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgRhs a -> LintM ()
    lintStgRhs GenStgRhs a
    rhs
            StgPprOpts
    opts <- LintM StgPprOpts
    getStgPprOpts
            -- Check binder doesn't have unlifted type or it's a join point
            Bool -> SDoc -> LintM ()
    checkL ( Id -> Bool
    isJoinId Id
    binder
                  Bool -> Bool -> Bool
    || Bool -> Bool
    not (HasDebugCallStack => Kind -> Bool
    Kind -> Bool
    isUnliftedType (Id -> Kind
    idType Id
    binder))
                  Bool -> Bool -> Bool
    || Id -> Bool
    isDataConWorkId Id
    binder Bool -> Bool -> Bool
    || Id -> Bool
    isDataConWrapId Id
    binder) -- until #17521 is fixed
              (StgPprOpts -> Id -> GenStgRhs a -> SDoc
    forall (a :: StgPass).
    OutputablePass a =>
    StgPprOpts -> Id -> GenStgRhs a -> SDoc
    mkUnliftedTyMsg StgPprOpts
    opts Id
    binder GenStgRhs a
    rhs)

    -- | Top-level bindings can't inherit the cost centre stack from their
    -- (static) allocation site.
    checkNoCurrentCCS
        :: (OutputablePass a, BinderP a ~ Id)
        => GenStgRhs a
        -> LintM ()
    checkNoCurrentCCS :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgRhs a -> LintM ()
    checkNoCurrentCCS GenStgRhs a
    rhs = do
       StgPprOpts
    opts <- LintM StgPprOpts
    getStgPprOpts
       let rhs' :: SDoc
    rhs' = StgPprOpts -> GenStgRhs a -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgRhs pass -> SDoc
    pprStgRhs StgPprOpts
    opts GenStgRhs a
    rhs
       case GenStgRhs a
    rhs of
          StgRhsClosure XRhsClosure a
    _ CostCentreStack
    ccs UpdateFlag
    _ [BinderP a]
    _ GenStgExpr a
    _
             | CostCentreStack -> Bool
    isCurrentCCS CostCentreStack
    ccs
             -> SDoc -> LintM ()
    addErrL (String -> SDoc
    text String
    "Top-level StgRhsClosure with CurrentCCS" SDoc -> SDoc -> SDoc
    $$ SDoc
    rhs')
          StgRhsCon CostCentreStack
    ccs DataCon
    _ ConstructorNumber
    _ [StgTickish]
    _ [StgArg]
    _
             | CostCentreStack -> Bool
    isCurrentCCS CostCentreStack
    ccs
             -> SDoc -> LintM ()
    addErrL (String -> SDoc
    text String
    "Top-level StgRhsCon with CurrentCCS" SDoc -> SDoc -> SDoc
    $$ SDoc
    rhs')
          GenStgRhs a
    _ -> () -> LintM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()

    lintStgRhs :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgRhs a -> LintM ()
    lintStgRhs (StgRhsClosure XRhsClosure a
    _ CostCentreStack
    _ UpdateFlag
    _ [] GenStgExpr a
    expr)
      = GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    expr

    lintStgRhs (StgRhsClosure XRhsClosure a
    _ CostCentreStack
    _ UpdateFlag
    _ [BinderP a]
    binders GenStgExpr a
    expr)
      = LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc ([Id] -> LintLocInfo
    LambdaBodyOf [Id]
    [BinderP a]
    binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
          [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    [BinderP a]
    binders (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
            GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    expr

    lintStgRhs rhs :: GenStgRhs a
    rhs@(StgRhsCon CostCentreStack
    _ DataCon
    con ConstructorNumber
    _ [StgTickish]
    _ [StgArg]
    args) = do
        Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    con Bool -> Bool -> Bool
    || DataCon -> Bool
    isUnboxedSumDataCon DataCon
    con) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ do
          StgPprOpts
    opts <- LintM StgPprOpts
    getStgPprOpts
          SDoc -> LintM ()
    addErrL (String -> SDoc
    text String
    "StgRhsCon is an unboxed tuple or sum application" SDoc -> SDoc -> SDoc
    $$
                   StgPprOpts -> GenStgRhs a -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgRhs pass -> SDoc
    pprStgRhs StgPprOpts
    opts GenStgRhs a
    rhs)
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    lintStgArg [StgArg]
    args
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    checkPostUnariseConArg [StgArg]
    args

    lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()

    lintStgExpr :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr (StgLit Literal
    _) = () -> LintM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    lintStgExpr (StgApp Id
    fun [StgArg]
    args) = do
        Id -> LintM ()
    lintStgVar Id
    fun
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    lintStgArg [StgArg]
    args

    lintStgExpr app :: GenStgExpr a
    app@(StgConApp DataCon
    con XConApp a
    _n [StgArg]
    args [Kind]
    _arg_tys) = do
        -- unboxed sums should vanish during unarise
        LintFlags
    lf <- LintM LintFlags
    getLintFlags
        Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LintFlags -> Bool
    lf_unarised LintFlags
    lf Bool -> Bool -> Bool
    && DataCon -> Bool
    isUnboxedSumDataCon DataCon
    con) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ do
          StgPprOpts
    opts <- LintM StgPprOpts
    getStgPprOpts
          SDoc -> LintM ()
    addErrL (String -> SDoc
    text String
    "Unboxed sum after unarise:" SDoc -> SDoc -> SDoc
    $$
                   StgPprOpts -> GenStgExpr a -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgExpr pass -> SDoc
    pprStgExpr StgPprOpts
    opts GenStgExpr a
    app)
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    lintStgArg [StgArg]
    args
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    checkPostUnariseConArg [StgArg]
    args

    lintStgExpr (StgOpApp StgOp
    _ [StgArg]
    args Kind
    _) =
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    lintStgArg [StgArg]
    args

    lintStgExpr (StgLet XLet a
    _ GenStgBinding a
    binds GenStgExpr a
    body) = do
        [Id]
    binders <- TopLevelFlag -> GenStgBinding a -> LintM [Id]
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> GenStgBinding a -> LintM [Id]
    lintStgBinds TopLevelFlag
    NotTopLevel GenStgBinding a
    binds
        LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc ([Id] -> LintLocInfo
    BodyOfLetRec [Id]
    binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
          [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    binders (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
            GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    body

    lintStgExpr (StgLetNoEscape XLetNoEscape a
    _ GenStgBinding a
    binds GenStgExpr a
    body) = do
        [Id]
    binders <- TopLevelFlag -> GenStgBinding a -> LintM [Id]
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    TopLevelFlag -> GenStgBinding a -> LintM [Id]
    lintStgBinds TopLevelFlag
    NotTopLevel GenStgBinding a
    binds
        LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc ([Id] -> LintLocInfo
    BodyOfLetRec [Id]
    binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
          [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    binders (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
            GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    body

    lintStgExpr (StgTick StgTickish
    _ GenStgExpr a
    expr) = GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    expr

    lintStgExpr (StgCase GenStgExpr a
    scrut BinderP a
    bndr AltType
    alts_type [GenStgAlt a]
    alts) = do
        GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    scrut

        LintFlags
    lf <- LintM LintFlags
    getLintFlags
        let in_scope :: Bool
    in_scope = AltType -> Bool -> Bool
    stgCaseBndrInScope AltType
    alts_type (LintFlags -> Bool
    lf_unarised LintFlags
    lf)

        [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id
    BinderP a
    bndr | Bool
    in_scope] (((AltCon, [Id], GenStgExpr a) -> LintM ())
    -> [(AltCon, [Id], GenStgExpr a)] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (AltCon, [Id], GenStgExpr a) -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    (AltCon, [Id], GenStgExpr a) -> LintM ()
    lintAlt [(AltCon, [Id], GenStgExpr a)]
    [GenStgAlt a]
    alts)

    lintAlt
        :: (OutputablePass a, BinderP a ~ Id)
        => (AltCon, [Id], GenStgExpr a) -> LintM ()

    lintAlt :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    (AltCon, [Id], GenStgExpr a) -> LintM ()
    lintAlt (AltCon
    DEFAULT, [Id]
    _, GenStgExpr a
    rhs) =
        GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    rhs

    lintAlt (LitAlt Literal
    _, [Id]
    _, GenStgExpr a
    rhs) =
        GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    rhs

    lintAlt (DataAlt DataCon
    _, [Id]
    bndrs, GenStgExpr a
    rhs) = do
        (Id -> LintM ()) -> [Id] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Id -> LintM ()
    checkPostUnariseBndr [Id]
    bndrs
        [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    bndrs (GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    rhs)

    {-
    ************************************************************************
    *                                                                      *
    The Lint monad
    *                                                                      *
    ************************************************************************
    -}

    newtype LintM a = LintM
        { forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM :: Module
                  -> LintFlags
                  -> StgPprOpts        -- Pretty-printing options
                  -> [LintLocInfo]     -- Locations
                  -> IdSet             -- Local vars in scope
                  -> Bag SDoc        -- Error messages so far
                  -> (a, Bag SDoc)   -- Result and error messages (if any)
        }
        deriving ((forall a b. (a -> b) -> LintM a -> LintM b)
    -> (forall a b. a -> LintM b -> LintM a) -> Functor LintM
    forall a b. a -> LintM b -> LintM a
    forall a b. (a -> b) -> LintM a -> LintM 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 -> LintM b -> LintM a
    $c<$ :: forall a b. a -> LintM b -> LintM a
    fmap :: forall a b. (a -> b) -> LintM a -> LintM b
    $cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
    Functor)

    data LintFlags = LintFlags { LintFlags -> Bool
    lf_unarised :: !Bool
                                 -- ^ have we run the unariser yet?
                               }

    data LintLocInfo
      = RhsOf Id            -- The variable bound
      | LambdaBodyOf [Id]   -- The lambda-binder
      | BodyOfLetRec [Id]   -- One of the binders

    dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
    dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
    dumpLoc (RhsOf Id
    v) =
      (SrcLoc -> SrcSpan
    srcLocSpan (Id -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Id
    v), String -> SDoc
    text String
    " [RHS of " SDoc -> SDoc -> SDoc
    <> [Id] -> SDoc
    pp_binders [Id
    v] SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    ']' )
    dumpLoc (LambdaBodyOf [Id]
    bs) =
      (SrcLoc -> SrcSpan
    srcLocSpan (Id -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc ([Id] -> Id
    forall a. [a] -> a
    head [Id]
    bs)), String -> SDoc
    text String
    " [in body of lambda with binders " SDoc -> SDoc -> SDoc
    <> [Id] -> SDoc
    pp_binders [Id]
    bs SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    ']' )

    dumpLoc (BodyOfLetRec [Id]
    bs) =
      (SrcLoc -> SrcSpan
    srcLocSpan (Id -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc ([Id] -> Id
    forall a. [a] -> a
    head [Id]
    bs)), String -> SDoc
    text String
    " [in body of letrec with binders " SDoc -> SDoc -> SDoc
    <> [Id] -> SDoc
    pp_binders [Id]
    bs SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    ']' )

    pp_binders :: [Id] -> SDoc
    pp_binders :: [Id] -> SDoc
    pp_binders [Id]
    bs
      = [SDoc] -> SDoc
    sep (SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma ((Id -> SDoc) -> [Id] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> SDoc
    pp_binder [Id]
    bs))
      where
        pp_binder :: Id -> SDoc
    pp_binder Id
    b
          = [SDoc] -> SDoc
    hsep [Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    b, SDoc
    dcolon, Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    b)]

    initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
    initL :: forall a.
    Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
    initL Module
    this_mod Bool
    unarised StgPprOpts
    opts IdSet
    locals (LintM Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    m) = do
      let (a
    _, Bag SDoc
    errs) = Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    m Module
    this_mod (Bool -> LintFlags
    LintFlags Bool
    unarised) StgPprOpts
    opts [] IdSet
    locals Bag SDoc
    forall a. Bag a
    emptyBag
      if Bag SDoc -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Bag SDoc
    errs then
          Maybe SDoc
    forall a. Maybe a
    Nothing
      else
          SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just ([SDoc] -> SDoc
    vcat (SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    blankLine (Bag SDoc -> [SDoc]
    forall a. Bag a -> [a]
    bagToList Bag SDoc
    errs)))

    instance Applicative LintM where
          pure :: forall a. a -> LintM a
    pure a
    a = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (a, Bag SDoc))
     -> LintM a)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (a, Bag SDoc))
    -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    _lf StgPprOpts
    _opts [LintLocInfo]
    _loc IdSet
    _scope Bag SDoc
    errs -> (a
    a, Bag SDoc
    errs)
          <*> :: forall a b. LintM (a -> b) -> LintM a -> LintM b
    (<*>) = LintM (a -> b) -> LintM a -> LintM b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap
          *> :: forall a b. LintM a -> LintM b -> LintM b
    (*>)  = LintM a -> LintM b -> LintM b
    forall a b. LintM a -> LintM b -> LintM b
    thenL_

    instance Monad LintM where
        >>= :: forall a b. LintM a -> (a -> LintM b) -> LintM b
    (>>=) = LintM a -> (a -> LintM b) -> LintM b
    forall a b. LintM a -> (a -> LintM b) -> LintM b
    thenL
        >> :: forall a b. LintM a -> LintM b -> LintM b
    (>>)  = LintM a -> LintM b -> LintM b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    (*>)

    thenL :: LintM a -> (a -> LintM b) -> LintM b
    thenL :: forall a b. LintM a -> (a -> LintM b) -> LintM b
    thenL LintM a
    m a -> LintM b
    k = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (b, Bag SDoc))
    -> LintM b
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (b, Bag SDoc))
     -> LintM b)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (b, Bag SDoc))
    -> LintM b
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
      -> case LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs of
          (a
    r, Bag SDoc
    errs') -> LintM b
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (b, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM (a -> LintM b
    k a
    r) Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs'

    thenL_ :: LintM a -> LintM b -> LintM b
    thenL_ :: forall a b. LintM a -> LintM b -> LintM b
    thenL_ LintM a
    m LintM b
    k = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (b, Bag SDoc))
    -> LintM b
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (b, Bag SDoc))
     -> LintM b)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (b, Bag SDoc))
    -> LintM b
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
      -> case LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs of
          (a
    _, Bag SDoc
    errs') -> LintM b
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (b, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM b
    k Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs'

    checkL :: Bool -> SDoc -> LintM ()
    checkL :: Bool -> SDoc -> LintM ()
    checkL Bool
    True  SDoc
    _   = () -> LintM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    checkL Bool
    False SDoc
    msg = SDoc -> LintM ()
    addErrL SDoc
    msg

    -- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
    checkPostUnariseBndr :: Id -> LintM ()
    checkPostUnariseBndr :: Id -> LintM ()
    checkPostUnariseBndr Id
    bndr = do
        LintFlags
    lf <- LintM LintFlags
    getLintFlags
        Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LintFlags -> Bool
    lf_unarised LintFlags
    lf) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
          Maybe String -> (String -> LintM ()) -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ (Id -> Maybe String
    checkPostUnariseId Id
    bndr) ((String -> LintM ()) -> LintM ())
    -> (String -> LintM ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \String
    unexpected ->
            SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
              String -> SDoc
    text String
    "After unarisation, binder " SDoc -> SDoc -> SDoc
    <>
              Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    bndr SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " has " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    unexpected SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " type " SDoc -> SDoc -> SDoc
    <>
              Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    bndr)

    -- Arguments shouldn't have sum, tuple, or void types.
    checkPostUnariseConArg :: StgArg -> LintM ()
    checkPostUnariseConArg :: StgArg -> LintM ()
    checkPostUnariseConArg StgArg
    arg = case StgArg
    arg of
        StgLitArg Literal
    _ ->
          () -> LintM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        StgVarArg Id
    id -> do
          LintFlags
    lf <- LintM LintFlags
    getLintFlags
          Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LintFlags -> Bool
    lf_unarised LintFlags
    lf) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
            Maybe String -> (String -> LintM ()) -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ (Id -> Maybe String
    checkPostUnariseId Id
    id) ((String -> LintM ()) -> LintM ())
    -> (String -> LintM ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \String
    unexpected ->
              SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                String -> SDoc
    text String
    "After unarisation, arg " SDoc -> SDoc -> SDoc
    <>
                Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    id SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " has " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    unexpected SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " type " SDoc -> SDoc -> SDoc
    <>
                Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    id)

    -- Post-unarisation args and case alt binders should not have unboxed tuple,
    -- unboxed sum, or void types. Return what the binder is if it is one of these.
    checkPostUnariseId :: Id -> Maybe String
    checkPostUnariseId :: Id -> Maybe String
    checkPostUnariseId Id
    id =
        let
          id_ty :: Kind
    id_ty = Id -> Kind
    idType Id
    id
          is_sum, is_tuple, is_void :: Maybe String
          is_sum :: Maybe String
    is_sum = Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Kind -> Bool
    isUnboxedSumType Kind
    id_ty) Maybe () -> Maybe String -> Maybe String
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> String -> Maybe String
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    "unboxed sum"
          is_tuple :: Maybe String
    is_tuple = Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Kind -> Bool
    isUnboxedTupleType Kind
    id_ty) Maybe () -> Maybe String -> Maybe String
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> String -> Maybe String
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    "unboxed tuple"
          is_void :: Maybe String
    is_void = Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Kind -> Bool
    isVoidTy Kind
    id_ty) Maybe () -> Maybe String -> Maybe String
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> String -> Maybe String
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    "void"
        in
          Maybe String
    is_sum Maybe String -> Maybe String -> Maybe String
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe String
    is_tuple Maybe String -> Maybe String -> Maybe String
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe String
    is_void

    addErrL :: SDoc -> LintM ()
    addErrL :: SDoc -> LintM ()
    addErrL SDoc
    msg = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> ((), Bag SDoc))
    -> LintM ()
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> ((), Bag SDoc))
     -> LintM ())
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> ((), Bag SDoc))
    -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    _lf StgPprOpts
    _opts [LintLocInfo]
    loc IdSet
    _scope Bag SDoc
    errs -> ((), Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr Bag SDoc
    errs SDoc
    msg [LintLocInfo]
    loc)

    addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr Bag SDoc
    errs_so_far SDoc
    msg [LintLocInfo]
    locs
      = Bag SDoc
    errs_so_far Bag SDoc -> SDoc -> Bag SDoc
    forall a. Bag a -> a -> Bag a
    `snocBag` [LintLocInfo] -> SDoc
    mk_msg [LintLocInfo]
    locs
      where
        mk_msg :: [LintLocInfo] -> SDoc
    mk_msg (LintLocInfo
    loc:[LintLocInfo]
    _) = let (SrcSpan
    l,SDoc
    hdr) = LintLocInfo -> (SrcSpan, SDoc)
    dumpLoc LintLocInfo
    loc
                         in  Severity -> SrcSpan -> SDoc -> SDoc
    mkLocMessage Severity
    SevWarning SrcSpan
    l (SDoc
    hdr SDoc -> SDoc -> SDoc
    $$ SDoc
    msg)
        mk_msg []      = SDoc
    msg

    addLoc :: LintLocInfo -> LintM a -> LintM a
    addLoc :: forall a. LintLocInfo -> LintM a -> LintM a
    addLoc LintLocInfo
    extra_loc LintM a
    m = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (a, Bag SDoc))
     -> LintM a)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (a, Bag SDoc))
    -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
       -> LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf StgPprOpts
    opts (LintLocInfo
    extra_locLintLocInfo -> [LintLocInfo] -> [LintLocInfo]
    forall a. a -> [a] -> [a]
    :[LintLocInfo]
    loc) IdSet
    scope Bag SDoc
    errs

    addInScopeVars :: [Id] -> LintM a -> LintM a
    addInScopeVars :: forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    ids LintM a
    m = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (a, Bag SDoc))
     -> LintM a)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (a, Bag SDoc))
    -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
     -> let
            new_set :: IdSet
    new_set = [Id] -> IdSet
    mkVarSet [Id]
    ids
        in LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf StgPprOpts
    opts [LintLocInfo]
    loc (IdSet
    scope IdSet -> IdSet -> IdSet
    `unionVarSet` IdSet
    new_set) Bag SDoc
    errs

    getLintFlags :: LintM LintFlags
    getLintFlags :: LintM LintFlags
    getLintFlags = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (LintFlags, Bag SDoc))
    -> LintM LintFlags
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (LintFlags, Bag SDoc))
     -> LintM LintFlags)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (LintFlags, Bag SDoc))
    -> LintM LintFlags
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    lf StgPprOpts
    _opts [LintLocInfo]
    _loc IdSet
    _scope Bag SDoc
    errs -> (LintFlags
    lf, Bag SDoc
    errs)

    getStgPprOpts :: LintM StgPprOpts
    getStgPprOpts :: LintM StgPprOpts
    getStgPprOpts = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (StgPprOpts, Bag SDoc))
    -> LintM StgPprOpts
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (StgPprOpts, Bag SDoc))
     -> LintM StgPprOpts)
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (StgPprOpts, Bag SDoc))
    -> LintM StgPprOpts
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    _lf StgPprOpts
    opts [LintLocInfo]
    _loc IdSet
    _scope Bag SDoc
    errs -> (StgPprOpts
    opts, Bag SDoc
    errs)

    checkInScope :: Id -> LintM ()
    checkInScope :: Id -> LintM ()
    checkInScope Id
    id = (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> ((), Bag SDoc))
    -> LintM ()
    forall a.
    (Module
     -> LintFlags
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> ((), Bag SDoc))
     -> LintM ())
    -> (Module
        -> LintFlags
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> ((), Bag SDoc))
    -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    _lf StgPprOpts
    _opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
     -> if Module -> Name -> Bool
    nameIsLocalOrFrom Module
    mod (Id -> Name
    idName Id
    id) Bool -> Bool -> Bool
    && Bool -> Bool
    not (Id
    id Id -> IdSet -> Bool
    `elemVarSet` IdSet
    scope) then
            ((), Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr Bag SDoc
    errs ([SDoc] -> SDoc
    hsep [Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    id, SDoc
    dcolon, Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    id),
                                    String -> SDoc
    text String
    "is out of scope"]) [LintLocInfo]
    loc)
        else
            ((), Bag SDoc
    errs)

    mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
    mkUnliftedTyMsg :: forall (a :: StgPass).
    OutputablePass a =>
    StgPprOpts -> Id -> GenStgRhs a -> SDoc
    mkUnliftedTyMsg StgPprOpts
    opts Id
    binder GenStgRhs a
    rhs
      = (String -> SDoc
    text String
    "Let(rec) binder" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    binder) SDoc -> SDoc -> SDoc
    <+>
         String -> SDoc
    text String
    "has unlifted type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    binder)))
        SDoc -> SDoc -> SDoc
    $$
        (String -> SDoc
    text String
    "RHS:" SDoc -> SDoc -> SDoc
    <+> StgPprOpts -> GenStgRhs a -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgRhs pass -> SDoc
    pprStgRhs StgPprOpts
    opts GenStgRhs a
    rhs)