    {- |
    (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-can-float
      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.

    Note [Linting StgApp]
    ~~~~~~~~~~~~~~~~~~~~~
    To lint an application of the form `f a_1 ... a_n`, we check that
    the representations of the arguments `a_1`, ..., `a_n` match those
    that the function expects.

    More precisely, suppose the types in the application `f a_1 ... a_n`
    are as follows:

      f :: t_1 -> ... -> t_n -> res
      a_1 :: s_1, ..., a_n :: s_n

      t_1 :: TYPE r_1, ..., t_n :: TYPE r_n
      s_1 :: TYPE p_1, ..., a_n :: TYPE p_n

    Before unarisation, we must check that each r_i is compatible with s_i.
    Compatibility is weaker than on-the-nose equality: for example,
    IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.

    After unarisation, a single type might correspond to multiple arguments, e.g.

      (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ])

    will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep]
    This means post unarise we potentially have to match up multiple arguments with
    the reps of a single argument in the type's definition, because the type of the function
    is *not* in unarised form.

    Wrinkle: it can sometimes happen that an argument type in the type of
    the function does not have a fixed runtime representation, i.e.
    there is an r_i such that runtimeRepPrimRep r_i crashes.
    See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example.
    Fixing this issue would require significant changes to the type system
    of STG, so for now we simply skip the Lint check when we detect such
    representation-polymorphic situations.

    Note [Typing the STG language]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In Core, programs must be /well-typed/.  So if f :: ty1 -> ty2,
    then in the application (f e), we must have  e :: ty1

    STG is still a statically typed language, but the type system
    is much coarser. In particular, STG programs must be /well-kinded/.
    More precisely, if f :: ty1 -> ty2, then in the application (f e)
    where e :: ty1', we must have kind(ty1) = kind(ty1').

    So the STG type system does not distinguish between Int and Bool,
    but it /does/ distinguish between Int and Int#, because they have
    different kinds.  Actually, since all terms have kind (TYPE rep),
    we might say that the STG language is well-runtime-rep'd.

    This coarser type system makes fewer distinctions, and that allows
    many nonsensical programs (such as ('x' && "foo")) -- but all type
    systems accept buggy programs!  But the coarseness also permits
    some optimisations that are ill-typed in Core.  For example, see
    the module STG.CSE, which is all about doing CSE in STG that would
    be ill-typed in Core.  But it must still be well-kinded!

    -}

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

    module GHC.Stg.Lint ( lintStgTopBindings ) where

    import GHC.Prelude

    import GHC.Stg.Syntax
    import GHC.Stg.Utils

    import GHC.Core.DataCon
    import GHC.Core             ( AltCon(..) )
    import GHC.Core.Type

    import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
    import GHC.Types.CostCentre ( isCurrentCCS )
    import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) )
    import GHC.Types.Id
    import GHC.Types.Var.Set
    import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
    import GHC.Types.RepType
    import GHC.Types.SrcLoc

    import GHC.Utils.Logger
    import GHC.Utils.Outputable
    import GHC.Utils.Error      ( mkLocMessage, DiagOpts )
    import qualified GHC.Utils.Error as Err

    import GHC.Unit.Module            ( Module )

    import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )

    import Control.Monad
    import Data.Maybe
    import GHC.Utils.Misc
    import GHC.Core.Multiplicity (scaledThing)
    import GHC.Settings (Platform)
    import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
    import GHC.Utils.Panic.Plain (panic)

    lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                       => Platform
                       -> Logger
                       -> DiagOpts
                       -> StgPprOpts
                       -> [Var]  -- ^ extra vars in scope from GHCi
                       -> 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) =>
    Platform
    -> Logger
    -> DiagOpts
    -> StgPprOpts
    -> [Id]
    -> Module
    -> Bool
    -> String
    -> [GenStgTopBinding a]
    -> IO ()
    lintStgTopBindings Platform
    platform Logger
    logger DiagOpts
    diag_opts StgPprOpts
    opts [Id]
    extra_vars Module
    this_mod Bool
    unarised String
    whodunit [GenStgTopBinding a]
    binds
      = {-# SCC "StgLint" #-}
        case Platform
    -> DiagOpts
    -> Module
    -> Bool
    -> StgPprOpts
    -> IdSet
    -> LintM ()
    -> Maybe SDoc
    forall a.
    Platform
    -> DiagOpts
    -> Module
    -> Bool
    -> StgPprOpts
    -> IdSet
    -> LintM a
    -> Maybe SDoc
    initL Platform
    platform DiagOpts
    diag_opts 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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          Just SDoc
    msg -> do
            Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    Err.MCInfo SrcSpan
    noSrcSpan   -- See Note [MCInfo for Lint] in "GHC.Core.Lint"
              (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle
              ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "*** Stg Lint ErrMsgs: in" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
                            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    whodunit SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "***",
                      SDoc
    msg,
                      String -> SDoc
    forall doc. IsLine doc => String -> doc
    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
    forall doc. IsLine doc => String -> doc
    text String
    "*** End of Offense ***"])
            Logger -> Int -> IO ()
    Err.ghcExit Logger
    logger Int
    1
      where
        -- 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))
                                           [Id]
    extra_vars

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

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

    lintStgConArg :: StgArg -> LintM ()
    lintStgConArg :: StgArg -> LintM ()
    lintStgConArg StgArg
    arg = do
      unarised <- LintFlags -> Bool
    lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LintM LintFlags
    getLintFlags
      when unarised $ case stgArgRep_maybe arg of
        -- Note [Post-unarisation invariants], invariant 4
        Just [PrimRep
    _] -> () -> LintM ()
    forall a. a -> LintM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        Maybe [PrimRep]
    badRep   -> SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
          String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-unary constructor arg: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> StgArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr StgArg
    arg SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
          String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Its PrimReps are: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Maybe [PrimRep] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe [PrimRep]
    badRep

      case arg of
        StgLitArg Literal
    _ -> () -> LintM ()
    forall a. a -> LintM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        StgVarArg Id
    v -> Id -> LintM ()
    lintStgVar Id
    v

    lintStgFunArg :: StgArg -> LintM ()
    lintStgFunArg :: StgArg -> LintM ()
    lintStgFunArg StgArg
    arg = do
      unarised <- LintFlags -> Bool
    lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LintM LintFlags
    getLintFlags
      when unarised $ case stgArgRep_maybe arg of
        -- Note [Post-unarisation invariants], invariant 3
        Just []  -> () -> LintM ()
    forall a. a -> LintM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        Just [PrimRep
    _] -> () -> LintM ()
    forall a. a -> LintM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        Maybe [PrimRep]
    badRep   -> SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
          String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Function arg is not unary or void: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> StgArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr StgArg
    arg SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
          String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Its PrimReps are: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Maybe [PrimRep] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe [PrimRep]
    badRep

      case arg of
        StgLitArg Literal
    _ -> () -> LintM ()
    forall a. a -> LintM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        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 a. a -> LintM a
    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 a. a -> LintM a
    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
            opts <- LintM StgPprOpts
    getStgPprOpts
            -- Check binder doesn't have unlifted type or it's a join point
            checkL ( isJoinId binder
                  || not (isUnliftedType (idType binder))
                  || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
              (mkUnliftedTyMsg opts binder 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
       opts <- LintM StgPprOpts
    getStgPprOpts
       let rhs' = StgPprOpts -> GenStgRhs a -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgRhs pass -> SDoc
    pprStgRhs StgPprOpts
    opts GenStgRhs a
    rhs
       case rhs of
          StgRhsClosure XRhsClosure a
    _ CostCentreStack
    ccs UpdateFlag
    _ [BinderP a]
    _ GenStgExpr a
    _ Kind
    _
             | CostCentreStack -> Bool
    isCurrentCCS CostCentreStack
    ccs
             -> SDoc -> LintM ()
    addErrL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Top-level StgRhsClosure with CurrentCCS" SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    rhs')
          StgRhsCon CostCentreStack
    ccs DataCon
    _ ConstructorNumber
    _ [StgTickish]
    _ [StgArg]
    _ Kind
    _
             | CostCentreStack -> Bool
    isCurrentCCS CostCentreStack
    ccs
             -> SDoc -> LintM ()
    addErrL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Top-level StgRhsCon with CurrentCCS" SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    rhs')
          GenStgRhs a
    _ -> () -> LintM ()
    forall a. a -> LintM a
    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 Kind
    _)
      = 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 Kind
    _)
      = 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 Kind
    _) = do
        opts <- LintM StgPprOpts
    getStgPprOpts
        when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
          addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
                   pprStgRhs opts rhs)

        lintConApp con args (pprStgRhs opts rhs)

    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 a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    lintStgExpr e :: GenStgExpr a
    e@(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 ()
    lintStgFunArg [StgArg]
    args
      GenStgExpr a -> LintM ()
    forall (pass :: StgPass).
    OutputablePass pass =>
    GenStgExpr pass -> LintM ()
    lintAppCbvMarks GenStgExpr a
    e
      Id -> [StgArg] -> LintM ()
    lintStgAppReps Id
    fun [StgArg]
    args

    lintStgExpr app :: GenStgExpr a
    app@(StgConApp DataCon
    con ConstructorNumber
    _n [StgArg]
    args [[PrimRep]]
    _arg_tys) = do
        -- unboxed sums should vanish during unarise
        lf <- LintM LintFlags
    getLintFlags
        let !unarised = LintFlags -> Bool
    lf_unarised LintFlags
    lf
        when (unarised && isUnboxedSumDataCon con) $ do
          opts <- getStgPprOpts
          addErrL (text "Unboxed sum after unarise:" $$
                   pprStgExpr opts app)

        opts <- getStgPprOpts
        lintConApp con args (pprStgExpr opts app)

    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 ()
    lintStgFunArg [StgArg]
    args

    lintStgExpr (StgLet XLet a
    _ GenStgBinding a
    binds GenStgExpr a
    body) = do
        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
        addLoc (BodyOfLet binders) $
          addInScopeVars binders $
            lintStgExpr body

    lintStgExpr (StgLetNoEscape XLetNoEscape a
    _ GenStgBinding a
    binds GenStgExpr a
    body) = do
        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
        addLoc (BodyOfLet binders) $
          addInScopeVars binders $
            lintStgExpr 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

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

        addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)

    lintAlt
        :: (OutputablePass a, BinderP a ~ Id)
        => GenStgAlt a -> LintM ()

    lintAlt :: forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgAlt a -> LintM ()
    lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con   = AltCon
    DEFAULT
                     , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
    alt_bndrs = [BinderP a]
    _
                     , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs   = GenStgExpr a
    rhs} = GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    rhs

    lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con   = LitAlt Literal
    _
                     , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
    alt_bndrs = [BinderP a]
    _
                     , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs   = GenStgExpr a
    rhs} = GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    rhs

    lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con   = DataAlt DataCon
    _
                     , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
    alt_bndrs = [BinderP a]
    bndrs
                     , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs   = 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]
    [BinderP a]
    bndrs
        [Id] -> LintM () -> LintM ()
    forall a. [Id] -> LintM a -> LintM a
    addInScopeVars [Id]
    [BinderP a]
    bndrs (GenStgExpr a -> LintM ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    GenStgExpr a -> LintM ()
    lintStgExpr GenStgExpr a
    rhs)

    lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM ()
    lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM ()
    lintConApp DataCon
    con [StgArg]
    args SDoc
    app = do
        (StgArg -> LintM ()) -> [StgArg] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StgArg -> LintM ()
    lintStgConArg [StgArg]
    args
        unarised <- LintFlags -> Bool
    lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LintM LintFlags
    getLintFlags

        -- Post unarise check we apply constructors to the right number of args.
        -- This can be violated by invalid use of unsafeCoerce as showcased by test
        -- T9208; see also #23865
        when (unarised &&
              not (isUnboxedTupleDataCon con) &&
              length (dataConRuntimeRepStrictness con) /= length args) $ do
          addErrL (text "Constructor applied to incorrect number of arguments:" $$
                   text "Application:" <> app)

    -- See Note [Linting StgApp]
    -- See Note [Typing the STG language]
    lintStgAppReps :: Id -> [StgArg] -> LintM ()
    lintStgAppReps :: Id -> [StgArg] -> LintM ()
    lintStgAppReps Id
    _fun [] = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    lintStgAppReps Id
    fun [StgArg]
    args = do
      lf <- LintM LintFlags
    getLintFlags
      let platform = LintFlags -> Platform
    lf_platform LintFlags
    lf

          (fun_arg_tys, _res) = splitFunTys (idType fun)
          fun_arg_tys' = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled Kind -> Kind
    forall a. Scaled a -> a
    scaledThing [Scaled Kind]
    fun_arg_tys :: [Type]

          -- Might be "wrongly" typed as polymorphic. See #21399
          -- In these cases typePrimRep_maybe will return Nothing
          -- and we abort kind checking.
          fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
          fun_arg_tys_reps = (Kind -> Maybe [PrimRep]) -> [Kind] -> [Maybe [PrimRep]]
    forall a b. (a -> b) -> [a] -> [b]
    map Kind -> Maybe [PrimRep]
    typePrimRep_maybe [Kind]
    fun_arg_tys'
          actual_arg_reps = (StgArg -> Maybe [PrimRep]) -> [StgArg] -> [Maybe [PrimRep]]
    forall a b. (a -> b) -> [a] -> [b]
    map StgArg -> Maybe [PrimRep]
    stgArgRep_maybe [StgArg]
    args

          match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
          match_args (Maybe [PrimRep]
    Nothing:[Maybe [PrimRep]]
    _) [Maybe [PrimRep]]
    _   = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          match_args ([Maybe [PrimRep]]
    _) (Maybe [PrimRep]
    Nothing:[Maybe [PrimRep]]
    _) = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          match_args (Just [PrimRep]
    actual_rep:[Maybe [PrimRep]]
    actual_reps_left) (Just [PrimRep]
    expected_rep:[Maybe [PrimRep]]
    expected_reps_left)
            -- Common case, reps are exactly the same (perhaps void)
            | [PrimRep]
    actual_rep [PrimRep] -> [PrimRep] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [PrimRep]
    expected_rep
            = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
    match_args [Maybe [PrimRep]]
    actual_reps_left [Maybe [PrimRep]]
    expected_reps_left

            -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.
            -- We check for that here with primRepCompatible
            | Platform -> [PrimRep] -> [PrimRep] -> Bool
    primRepsCompatible Platform
    platform [PrimRep]
    actual_rep [PrimRep]
    expected_rep
            = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
    match_args [Maybe [PrimRep]]
    actual_reps_left [Maybe [PrimRep]]
    expected_reps_left

            -- We might distribute args from within one unboxed sum over multiple
            -- single rep args. This means we might need to match up things like:
            -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]]
            -- which happens here.
            -- See Note [Linting StgApp].
            | Just (PrimRep
    actual,[Maybe [PrimRep]]
    actuals) <- [PrimRep]
    -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
    getOneRep [PrimRep]
    actual_rep [Maybe [PrimRep]]
    actual_reps_left
            , Just (PrimRep
    expected,[Maybe [PrimRep]]
    expecteds) <- [PrimRep]
    -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
    getOneRep [PrimRep]
    expected_rep [Maybe [PrimRep]]
    expected_reps_left
            , Platform -> PrimRep -> PrimRep -> Bool
    primRepCompatible Platform
    platform PrimRep
    actual PrimRep
    expected
            = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
    match_args [Maybe [PrimRep]]
    actuals [Maybe [PrimRep]]
    expecteds

            | Bool
    otherwise = SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Function type reps and function argument reps mismatched") Int
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In application " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    fun SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [StgArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [StgArg]
    args SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                  String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "argument rep:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> [Maybe [PrimRep]] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Maybe [PrimRep]]
    actual_arg_reps SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                  String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "expected rep:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> [Maybe [PrimRep]] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Maybe [PrimRep]]
    fun_arg_tys_reps SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                  -- text "expected reps:" <> ppr arg_ty_reps $$
                  String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "unarised?:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (LintFlags -> Bool
    lf_unarised LintFlags
    lf))
            where
              -- Try to strip one non-void arg rep from the current argument type returning
              -- the remaining list of arguments. We return Nothing for invalid input which
              -- will result in a lint failure in match_args.
              getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
              getOneRep :: [PrimRep]
    -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
    getOneRep [] [Maybe [PrimRep]]
    _rest = Maybe (PrimRep, [Maybe [PrimRep]])
    forall a. Maybe a
    Nothing -- Void rep args are invalid at this point.
              getOneRep [PrimRep
    rep] [Maybe [PrimRep]]
    rest = (PrimRep, [Maybe [PrimRep]]) -> Maybe (PrimRep, [Maybe [PrimRep]])
    forall a. a -> Maybe a
    Just (PrimRep
    rep,[Maybe [PrimRep]]
    rest) -- A single arg rep arg
              getOneRep (PrimRep
    rep:[PrimRep]
    reps) [Maybe [PrimRep]]
    rest = (PrimRep, [Maybe [PrimRep]]) -> Maybe (PrimRep, [Maybe [PrimRep]])
    forall a. a -> Maybe a
    Just (PrimRep
    rep,[PrimRep] -> Maybe [PrimRep]
    forall a. a -> Maybe a
    Just [PrimRep]
    repsMaybe [PrimRep] -> [Maybe [PrimRep]] -> [Maybe [PrimRep]]
    forall a. a -> [a] -> [a]
    :[Maybe [PrimRep]]
    rest) -- Multi rep arg.

          match_args [Maybe [PrimRep]]
    _ [Maybe [PrimRep]]
    _ = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () -- Functions are allowed to be over/under applied.

      match_args actual_arg_reps fun_arg_tys_reps

    lintAppCbvMarks :: OutputablePass pass
                    => GenStgExpr pass -> LintM ()
    lintAppCbvMarks :: forall (pass :: StgPass).
    OutputablePass pass =>
    GenStgExpr pass -> LintM ()
    lintAppCbvMarks e :: GenStgExpr pass
    e@(StgApp Id
    fun [StgArg]
    args) = do
      lf <- LintM LintFlags
    getLintFlags
      when (lf_unarised lf) $ do
        -- A function which expects a unlifted argument as n'th argument
        -- always needs to be applied to n arguments.
        -- See Note [CBV Function Ids].
        let marks = [CbvMark] -> Maybe [CbvMark] -> [CbvMark]
    forall a. a -> Maybe a -> a
    fromMaybe [] (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
    forall a b. (a -> b) -> a -> b
    $ Id -> Maybe [CbvMark]
    idCbvMarks_maybe Id
    fun
        when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do
          addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $
            (text "marks" <> ppr marks $$
            text "args" <> ppr args $$
            text "arity" <> ppr (idArity fun) $$
            text "join_arity" <> ppr (idJoinPointHood fun))
    lintAppCbvMarks GenStgExpr pass
    _ = String -> LintM ()
    forall a. HasCallStack => String -> a
    panic String
    "impossible - lintAppCbvMarks"

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

    newtype LintM a = LintM
        { forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM :: Module
                  -> LintFlags
                  -> DiagOpts          -- Diagnostic options
                  -> 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
    $cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
    fmap :: forall a b. (a -> b) -> LintM a -> LintM b
    $c<$ :: forall a b. a -> LintM b -> LintM a
    <$ :: forall a b. a -> LintM b -> LintM a
    Functor)

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

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

    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
    forall doc. IsLine doc => String -> doc
    text String
    " [RHS of " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> [Id] -> SDoc
    pp_binders [Id
    v] SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    ']' )
    dumpLoc (LambdaBodyOf [Id]
    bs) =
      (SrcLoc -> SrcSpan
    srcLocSpan (Id -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc ([Id] -> Id
    forall a. HasCallStack => [a] -> a
    head [Id]
    bs)), String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    " [in body of lambda with binders " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> [Id] -> SDoc
    pp_binders [Id]
    bs SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    ']' )

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

    pp_binders :: [Id] -> SDoc
    pp_binders :: [Id] -> SDoc
    pp_binders [Id]
    bs
      = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    sep (SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    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
    forall doc. IsLine doc => [doc] -> doc
    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 :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
    initL :: forall a.
    Platform
    -> DiagOpts
    -> Module
    -> Bool
    -> StgPprOpts
    -> IdSet
    -> LintM a
    -> Maybe SDoc
    initL Platform
    platform DiagOpts
    diag_opts Module
    this_mod Bool
    unarised StgPprOpts
    opts IdSet
    locals (LintM Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    m) = do
      let (a
    _, Bag SDoc
    errs) = Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    m Module
    this_mod (Bool -> Platform -> LintFlags
    LintFlags Bool
    unarised Platform
    platform) DiagOpts
    diag_opts 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
    forall doc. IsDoc doc => [doc] -> doc
    vcat (SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (a, Bag SDoc))
     -> LintM a)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (a, Bag SDoc))
    -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    _lf DiagOpts
    _df 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 a 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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (b, Bag SDoc))
    -> LintM b
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (b, Bag SDoc))
     -> LintM b)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (b, Bag SDoc))
    -> LintM b
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf DiagOpts
    diag_opts StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
      -> case LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf DiagOpts
    diag_opts StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs of
          (a
    r, Bag SDoc
    errs') -> LintM b
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (b, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM (a -> LintM b
    k a
    r) Module
    mod LintFlags
    lf DiagOpts
    diag_opts 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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (b, Bag SDoc))
    -> LintM b
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (b, Bag SDoc))
     -> LintM b)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (b, Bag SDoc))
    -> LintM b
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf DiagOpts
    diag_opts StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
      -> case LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf DiagOpts
    diag_opts StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs of
          (a
    _, Bag SDoc
    errs') -> LintM b
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (b, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM b
    k Module
    mod LintFlags
    lf DiagOpts
    diag_opts StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs'

    checkL :: Bool -> SDoc -> LintM ()
    checkL :: Bool -> SDoc -> LintM ()
    checkL Bool
    True  SDoc
    _   = () -> LintM ()
    forall a. a -> LintM a
    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
        lf <- LintM LintFlags
    getLintFlags
        when (lf_unarised lf) $
          forM_ (checkPostUnariseId bndr) $ \String
    unexpected ->
            SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "After unarisation, binder " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
              Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    bndr SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    " has " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    unexpected SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    " type " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
              Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    bndr)

    -- 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
      | Kind -> Bool
    isUnboxedSumType Kind
    id_ty   = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "unboxed sum"
      | Kind -> Bool
    isUnboxedTupleType Kind
    id_ty = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "unboxed tuple"
      | HasDebugCallStack => Kind -> Bool
    Kind -> Bool
    isZeroBitTy Kind
    id_ty        = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "void"
      | Bool
    otherwise                = Maybe String
    forall a. Maybe a
    Nothing
      where
        id_ty :: Kind
    id_ty = Id -> Kind
    idType Id
    id

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

    addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr DiagOpts
    diag_opts 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  MessageClass -> SrcSpan -> SDoc -> SDoc
    mkLocMessage (DiagOpts
    -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    Err.mkMCDiagnostic DiagOpts
    diag_opts DiagnosticReason
    WarningWithoutFlag Maybe DiagnosticCode
    forall a. Maybe a
    Nothing)
                                          SrcSpan
    l (SDoc
    hdr SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ 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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (a, Bag SDoc))
     -> LintM a)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (a, Bag SDoc))
    -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf DiagOpts
    diag_opts StgPprOpts
    opts [LintLocInfo]
    loc IdSet
    scope Bag SDoc
    errs
       -> LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf DiagOpts
    diag_opts 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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (a, Bag SDoc))
     -> LintM a)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (a, Bag SDoc))
    -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    lf DiagOpts
    diag_opts 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
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    forall a.
    LintM a
    -> Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc)
    unLintM LintM a
    m Module
    mod LintFlags
    lf DiagOpts
    diag_opts 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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (LintFlags, Bag SDoc))
    -> LintM LintFlags
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (LintFlags, Bag SDoc))
     -> LintM LintFlags)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (LintFlags, Bag SDoc))
    -> LintM LintFlags
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    lf DiagOpts
    _df StgPprOpts
    _opts [LintLocInfo]
    _loc IdSet
    _scope Bag SDoc
    errs -> (LintFlags
    lf, Bag SDoc
    errs)

    getStgPprOpts :: LintM StgPprOpts
    getStgPprOpts :: LintM StgPprOpts
    getStgPprOpts = (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (StgPprOpts, Bag SDoc))
    -> LintM StgPprOpts
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> (StgPprOpts, Bag SDoc))
     -> LintM StgPprOpts)
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> (StgPprOpts, Bag SDoc))
    -> LintM StgPprOpts
    forall a b. (a -> b) -> a -> b
    $ \Module
    _mod LintFlags
    _lf DiagOpts
    _df 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
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> ((), Bag SDoc))
    -> LintM ()
    forall a.
    (Module
     -> LintFlags
     -> DiagOpts
     -> StgPprOpts
     -> [LintLocInfo]
     -> IdSet
     -> Bag SDoc
     -> (a, Bag SDoc))
    -> LintM a
    LintM ((Module
      -> LintFlags
      -> DiagOpts
      -> StgPprOpts
      -> [LintLocInfo]
      -> IdSet
      -> Bag SDoc
      -> ((), Bag SDoc))
     -> LintM ())
    -> (Module
        -> LintFlags
        -> DiagOpts
        -> StgPprOpts
        -> [LintLocInfo]
        -> IdSet
        -> Bag SDoc
        -> ((), Bag SDoc))
    -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \Module
    mod LintFlags
    _lf DiagOpts
    diag_opts 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
            ((), DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
    addErr DiagOpts
    diag_opts Bag SDoc
    errs ([SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    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
    forall doc. IsLine doc => String -> doc
    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
    forall doc. IsLine doc => String -> doc
    text String
    "Let(rec) binder" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    binder) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
         String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "has unlifted type" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    binder)))
        SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
        (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "RHS:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> StgPprOpts -> GenStgRhs a -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgRhs pass -> SDoc
    pprStgRhs StgPprOpts
    opts GenStgRhs a
    rhs)