    {-# LANGUAGE MultiWayIf          #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE PatternSynonyms #-}
    {-# LANGUAGE UnboxedTuples #-}

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

    A ``lint'' pass to check for Core correctness.
    See Note [Core Lint guarantee].
    -}

    module GHC.Core.Lint (
        LintPassResultConfig (..),
        LintFlags (..),
        StaticPtrCheck (..),
        LintConfig (..),
        WarnsAndErrs,

        lintCoreBindings', lintUnfolding,
        lintPassResult, lintExpr,
        lintAnnots, lintAxioms,

        -- ** Debug output
        EndPassConfig (..),
        endPassIO,
        displayLintResults, dumpPassResult
     ) where

    import GHC.Prelude

    import GHC.Driver.DynFlags

    import GHC.Tc.Utils.TcType
      ( ConcreteTvOrigin(..), ConcreteTyVars
      , isFloatingPrimTy, isTyFamFree )
    import GHC.Tc.Types.Origin
      ( FixedRuntimeRepOrigin(..) )
    import GHC.Unit.Module.ModGuts
    import GHC.Platform

    import GHC.Core
    import GHC.Core.FVs
    import GHC.Core.Utils
    import GHC.Core.Stats ( coreBindsStats )
    import GHC.Core.DataCon
    import GHC.Core.Ppr
    import GHC.Core.Coercion
    import GHC.Core.Type as Type
    import GHC.Core.Predicate( isCoVarType )
    import GHC.Core.Multiplicity
    import GHC.Core.UsageEnv
    import GHC.Core.TyCo.Rep   -- checks validity of types/coercions
    import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis )
    import GHC.Core.TyCo.Subst
    import GHC.Core.TyCo.FVs
    import GHC.Core.TyCo.Ppr
    import GHC.Core.TyCon as TyCon
    import GHC.Core.Coercion.Axiom
    import GHC.Core.FamInstEnv( compatibleBranches )
    import GHC.Core.Unify
    import GHC.Core.Opt.Arity    ( typeArity, exprIsDeadEnd )

    import GHC.Core.Opt.Monad

    import GHC.Types.Literal
    import GHC.Types.Var as Var
    import GHC.Types.Var.Env
    import GHC.Types.Var.Set
    import GHC.Types.Name
    import GHC.Types.Name.Env
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.SrcLoc
    import GHC.Types.Tickish
    import GHC.Types.Unique.FM ( isNullUFM, sizeUFM )
    import GHC.Types.RepType
    import GHC.Types.Basic
    import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )

    import GHC.Builtin.Names
    import GHC.Builtin.Types.Prim
    import GHC.Builtin.Types ( multiplicityTy )

    import GHC.Data.Bag
    import GHC.Data.List.SetOps

    import GHC.Utils.Monad
    import GHC.Utils.Outputable as Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Constants (debugIsOn)
    import GHC.Utils.Misc
    import GHC.Utils.Error
    import qualified GHC.Utils.Error as Err
    import GHC.Utils.Logger

    import Control.Monad
    import Data.Foldable      ( for_, toList )
    import Data.List.NonEmpty ( NonEmpty(..), groupWith )
    import Data.List          ( partition )
    import Data.Maybe
    import Data.IntMap.Strict ( IntMap )
    import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )
    import GHC.Data.Pair
    import GHC.Base (oneShot)
    import GHC.Data.Unboxed

    {-
    Note [Core Lint guarantee]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Core Lint is the type-checker for Core. Using it, we get the following guarantee:

    If all of:
    1. Core Lint passes,
    2. there are no unsafe coercions (i.e. unsafeEqualityProof),
    3. all plugin-supplied coercions (i.e. PluginProv) are valid, and
    4. all case-matches are complete
    then running the compiled program will not seg-fault, assuming no bugs downstream
    (e.g. in the code generator). This guarantee is quite powerful, in that it allows us
    to decouple the safety of the resulting program from the type inference algorithm.

    However, do note point (4) above. Core Lint does not check for incomplete case-matches;
    see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there,
    an incomplete case-match might slip by Core Lint and cause trouble at runtime.

    Note [GHC Formalism]
    ~~~~~~~~~~~~~~~~~~~~
    This file implements the type-checking algorithm for System FC, the "official"
    name of the Core language. Type safety of FC is heart of the claim that
    executables produced by GHC do not have segmentation faults. Thus, it is
    useful to be able to reason about System FC independently of reading the code.
    To this purpose, there is a document core-spec.pdf built in docs/core-spec that
    contains a formalism of the types and functions dealt with here. If you change
    just about anything in this file or you change other types/functions throughout
    the Core language (all signposted to this note), you should update that
    formalism. See docs/core-spec/README for more info about how to do so.

    Note [check vs lint]
    ~~~~~~~~~~~~~~~~~~~~
    This file implements both a type checking algorithm and also general sanity
    checking. For example, the "sanity checking" checks for TyConApp on the left
    of an AppTy, which should never happen. These sanity checks don't really
    affect any notion of type soundness. Yet, it is convenient to do the sanity
    checks at the same time as the type checks. So, we use the following naming
    convention:

    - Functions that begin with 'lint'... are involved in type checking. These
      functions might also do some sanity checking.

    - Functions that begin with 'check'... are *not* involved in type checking.
      They exist only for sanity checking.

    Issues surrounding variable naming, shadowing, and such are considered *not*
    to be part of type checking, as the formalism omits these details.

    Summary of checks
    ~~~~~~~~~~~~~~~~~
    Checks that a set of core bindings is well-formed.  The PprStyle and String
    just control what we print in the event of an error.  The Bool value
    indicates whether we have done any specialisation yet (in which case we do
    some extra checks).

    We check for
            (a) type errors
            (b) Out-of-scope type variables
            (c) Out-of-scope local variables
            (d) Ill-kinded types
            (e) Incorrect unsafe coercions

    If we have done specialisation the we check that there are
            (a) No top-level bindings of primitive (unboxed type)

    Note [Linting function types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    All saturated applications of funTyCon are represented with the FunTy constructor.
    See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim

     We check this invariant in lintType.

    Note [Linting type lets]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    In the desugarer, it's very very convenient to be able to say (in effect)
            let a = Type Bool in
            let x::a = True in <body>
    That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".
    One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]
    in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).

    * Hence when linting <body> we need to remember that a=Int, else we
      might reject a correct program.  So we carry a type substitution (in
      this example [a -> Bool]) and apply this substitution before
      comparing types. In effect, in Lint, type equality is always
      equality-modulo-le-subst.  This is in the le_subst field of
      LintEnv.  But nota bene:

      (SI1) The le_subst substitution is applied to types and coercions only

      (SI2) The result of that substitution is used only to check for type
            equality, to check well-typed-ness, /but is then discarded/.
            The result of substitution does not outlive the CoreLint pass.

      (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.

    * The function
            lintInTy :: Type -> LintM (Type, Kind)
      returns a substituted type.

    * When we encounter a binder (like x::a) we must apply the substitution
      to the type of the binding variable.  lintBinders does this.

    * Clearly we need to clone tyvar binders as we go.

    * But take care (#17590)! We must also clone CoVar binders:
        let a = TYPE (ty |> cv)
        in \cv -> blah
      blindly substituting for `a` might capture `cv`.

    * Alas, when cloning a coercion variable we might choose a unique
      that happens to clash with an inner Id, thus
          \cv_66 -> let wild_X7 = blah in blah
      We decide to clone `cv_66` because it's already in scope.  Fine,
      choose a new unique.  Aha, X7 looks good.  So we check the lambda
      body with le_subst of [cv_66 :-> cv_X7]

      This is all fine, even though we use the same unique as wild_X7.
      As (SI2) says, we do /not/ return a new lambda
         (\cv_X7 -> let wild_X7 = blah in ...)
      We simply use the le_subst substitution in types/coercions only, when
      checking for equality.

    * We still need to check that Id occurrences are bound by some
      enclosing binding.  We do /not/ use the InScopeSet for the le_subst
      for this purpose -- it contains only TyCoVars.  Instead we have a separate
      le_ids for the in-scope Id binders.

    Sigh.  We might want to explore getting rid of type-let!

    Note [Bad unsafe coercion]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions
    Linter introduces additional rules that checks improper coercion between
    different types, called bad coercions. Following coercions are forbidden:

      (a) coercions between boxed and unboxed values;
      (b) coercions between unlifted values of the different sizes, here
          active size is checked, i.e. size of the actual value but not
          the space allocated for value;
      (c) coercions between floating and integral boxed values, this check
          is not yet supported for unboxed tuples, as no semantics were
          specified for that;
      (d) coercions from / to vector type
      (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be
          coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules
          (a-e) holds.

    Note [Join points]
    ~~~~~~~~~~~~~~~~~~
    We check the rules listed in Note [Invariants on join points] in GHC.Core. The
    only one that causes any difficulty is the first: All occurrences must be tail
    calls. To this end, along with the in-scope set, we remember in le_joins the
    subset of in-scope Ids that are valid join ids. For example:

      join j x = ... in
      case e of
        A -> jump j y -- good
        B -> case (jump j z) of -- BAD
               C -> join h = jump j w in ... -- good
               D -> let x = jump j v in ... -- BAD

    A join point remains valid in case branches, so when checking the A
    branch, j is still valid. When we check the scrutinee of the inner
    case, however, we set le_joins to empty, and catch the
    error. Similarly, join points can occur free in RHSes of other join
    points but not the RHSes of value bindings (thunks and functions).

    Note [Avoiding compiler perf traps when constructing error messages.]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It's quite common to put error messages into a where clause when it might
    be triggered by multiple branches. E.g.

      checkThing x y z =
        case x of
          X -> unless (correctX x) $ failWithL errMsg
          Y -> unless (correctY y) $ failWithL errMsg
        where
          errMsg = text "My error involving:" $$ ppr x <+> ppr y

    However ghc will compile this to:

      checkThink x y z =
        let errMsg = text "My error involving:" $$ ppr x <+> ppr y
        in case x of
          X -> unless (correctX x) $ failWithL errMsg
          Y -> unless (correctY y) $ failWithL errMsg

    Putting the allocation of errMsg into the common non-error path.
    One way to work around this is to turn errMsg into a function:

      checkThink x y z =
        case x of
          X -> unless (correctX x) $ failWithL (errMsg x y)
          Y -> unless (correctY y) $ failWithL (errMsg x y)
        where
          errMsg x y = text "My error involving:" $$ ppr x <+> ppr y

    This way `errMsg` is a static function and it being defined in the common
    path does not result in allocation in the hot path. This can be surprisingly
    impactful. Changing `lint_app` reduced allocations for one test program I was
    looking at by ~4%.

    Note [MCInfo for Lint]
    ~~~~~~~~~~~~~~~~~~~~~~
    When printing a Lint message, use the MCInfo severity so that the
    message is printed on stderr rather than stdout (#13342).

    ************************************************************************
    *                                                                      *
                     Beginning and ending passes
    *                                                                      *
    ************************************************************************
    -}

    -- | Configuration for boilerplate operations at the end of a
    -- compilation pass producing Core.
    data EndPassConfig = EndPassConfig
      { EndPassConfig -> Bool
    ep_dumpCoreSizes :: !Bool
      -- ^ Whether core bindings should be dumped with the size of what they
      -- are binding (i.e. the size of the RHS of the binding).

      , EndPassConfig -> Maybe LintPassResultConfig
    ep_lintPassResult :: !(Maybe LintPassResultConfig)
      -- ^ Whether we should lint the result of this pass.

      , EndPassConfig -> NamePprCtx
    ep_namePprCtx :: !NamePprCtx

      , EndPassConfig -> Maybe DumpFlag
    ep_dumpFlag :: !(Maybe DumpFlag)

      , EndPassConfig -> SDoc
    ep_prettyPass :: !SDoc

      , EndPassConfig -> SDoc
    ep_passDetails :: !SDoc
      }

    endPassIO :: Logger
              -> EndPassConfig
              -> CoreProgram -> [CoreRule]
              -> IO ()
    -- Used by the IO-is CorePrep too
    endPassIO :: Logger -> EndPassConfig -> CoreProgram -> [CoreRule] -> IO ()
    endPassIO Logger
    logger EndPassConfig
    cfg CoreProgram
    binds [CoreRule]
    rules
      = do { Logger
    -> Bool
    -> NamePprCtx
    -> Maybe DumpFlag
    -> String
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dumpPassResult Logger
    logger (EndPassConfig -> Bool
    ep_dumpCoreSizes EndPassConfig
    cfg) (EndPassConfig -> NamePprCtx
    ep_namePprCtx EndPassConfig
    cfg) Maybe DumpFlag
    mb_flag
                            (SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (EndPassConfig -> SDoc
    ep_prettyPass EndPassConfig
    cfg))
                            (EndPassConfig -> SDoc
    ep_passDetails EndPassConfig
    cfg) CoreProgram
    binds [CoreRule]
    rules
           ; Maybe LintPassResultConfig
    -> (LintPassResultConfig -> IO ()) -> IO ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    t a -> (a -> f b) -> f ()
    for_ (EndPassConfig -> Maybe LintPassResultConfig
    ep_lintPassResult EndPassConfig
    cfg) ((LintPassResultConfig -> IO ()) -> IO ())
    -> (LintPassResultConfig -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \LintPassResultConfig
    lp_cfg ->
               Logger -> LintPassResultConfig -> CoreProgram -> IO ()
    lintPassResult Logger
    logger LintPassResultConfig
    lp_cfg CoreProgram
    binds
           }
      where
        mb_flag :: Maybe DumpFlag
    mb_flag = case EndPassConfig -> Maybe DumpFlag
    ep_dumpFlag EndPassConfig
    cfg of
                    Just DumpFlag
    flag | Logger -> DumpFlag -> Bool
    logHasDumpFlag Logger
    logger DumpFlag
    flag                    -> DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    flag
                              | Logger -> DumpFlag -> Bool
    logHasDumpFlag Logger
    logger DumpFlag
    Opt_D_verbose_core2core -> DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    flag
                    Maybe DumpFlag
    _ -> Maybe DumpFlag
    forall a. Maybe a
    Nothing

    dumpPassResult :: Logger
                   -> Bool                  -- dump core sizes?
                   -> NamePprCtx
                   -> Maybe DumpFlag        -- Just df => show details in a file whose
                                            --            name is specified by df
                   -> String                -- Header
                   -> SDoc                  -- Extra info to appear after header
                   -> CoreProgram -> [CoreRule]
                   -> IO ()
    dumpPassResult :: Logger
    -> Bool
    -> NamePprCtx
    -> Maybe DumpFlag
    -> String
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dumpPassResult Logger
    logger Bool
    dump_core_sizes NamePprCtx
    name_ppr_ctx Maybe DumpFlag
    mb_flag String
    hdr SDoc
    extra_info CoreProgram
    binds [CoreRule]
    rules
      = do { Maybe DumpFlag -> (DumpFlag -> IO ()) -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ Maybe DumpFlag
    mb_flag ((DumpFlag -> IO ()) -> IO ()) -> (DumpFlag -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \DumpFlag
    flag -> do
               Logger
    -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    logDumpFile Logger
    logger (NamePprCtx -> PprStyle
    mkDumpStyle NamePprCtx
    name_ppr_ctx) DumpFlag
    flag String
    hdr DumpFormat
    FormatCore SDoc
    dump_doc

             -- Report result size
             -- This has the side effect of forcing the intermediate to be evaluated
             -- if it's not already forced by a -ddump flag.
           ; Logger -> JoinArity -> SDoc -> IO ()
    Err.debugTraceMsg Logger
    logger JoinArity
    2 SDoc
    size_doc
           }

      where
        size_doc :: SDoc
    size_doc = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    sep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Result size of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    hdr, JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (SDoc
    forall doc. IsLine doc => doc
    equals SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreStats -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CoreProgram -> CoreStats
    coreBindsStats CoreProgram
    binds))]

        dump_doc :: SDoc
    dump_doc  = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 SDoc
    extra_info
                         , SDoc
    size_doc
                         , SDoc
    blankLine
                         , if Bool
    dump_core_sizes
                            then CoreProgram -> SDoc
    pprCoreBindingsWithSize CoreProgram
    binds
                            else CoreProgram -> SDoc
    forall b. OutputableBndr b => [Bind b] -> SDoc
    pprCoreBindings         CoreProgram
    binds
                         , Bool -> SDoc -> SDoc
    forall doc. IsOutput doc => Bool -> doc -> doc
    ppUnless ([CoreRule] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [CoreRule]
    rules) SDoc
    pp_rules ]
        pp_rules :: SDoc
    pp_rules = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ SDoc
    blankLine
                        , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "------ Local rules for imported ids --------"
                        , [CoreRule] -> SDoc
    pprRules [CoreRule]
    rules ]

    {-
    ************************************************************************
    *                                                                      *
                     Top-level interfaces
    *                                                                      *
    ************************************************************************
    -}

    data LintPassResultConfig = LintPassResultConfig
      { LintPassResultConfig -> DiagOpts
    lpr_diagOpts         :: !DiagOpts
      , LintPassResultConfig -> Platform
    lpr_platform         :: !Platform
      , LintPassResultConfig -> LintFlags
    lpr_makeLintFlags    :: !LintFlags
      , LintPassResultConfig -> Bool
    lpr_showLintWarnings :: !Bool
      , LintPassResultConfig -> SDoc
    lpr_passPpr          :: !SDoc
      , LintPassResultConfig -> [Var]
    lpr_localsInScope    :: ![Var]
      }

    lintPassResult :: Logger -> LintPassResultConfig
                   -> CoreProgram -> IO ()
    lintPassResult :: Logger -> LintPassResultConfig -> CoreProgram -> IO ()
    lintPassResult Logger
    logger LintPassResultConfig
    cfg CoreProgram
    binds
      = do { let warns_and_errs :: WarnsAndErrs
    warns_and_errs = LintConfig -> CoreProgram -> WarnsAndErrs
    lintCoreBindings'
                   (LintConfig
                    { l_diagOpts :: DiagOpts
    l_diagOpts = LintPassResultConfig -> DiagOpts
    lpr_diagOpts LintPassResultConfig
    cfg
                    , l_platform :: Platform
    l_platform = LintPassResultConfig -> Platform
    lpr_platform LintPassResultConfig
    cfg
                    , l_flags :: LintFlags
    l_flags    = LintPassResultConfig -> LintFlags
    lpr_makeLintFlags LintPassResultConfig
    cfg
                    , l_vars :: [Var]
    l_vars     = LintPassResultConfig -> [Var]
    lpr_localsInScope LintPassResultConfig
    cfg
                    })
                   CoreProgram
    binds
           ; Logger -> String -> IO ()
    Err.showPass Logger
    logger (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $
               String
    "Core Linted result of " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
               SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (LintPassResultConfig -> SDoc
    lpr_passPpr LintPassResultConfig
    cfg)
           ; Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
    displayLintResults Logger
    logger
                                (LintPassResultConfig -> Bool
    lpr_showLintWarnings LintPassResultConfig
    cfg) (LintPassResultConfig -> SDoc
    lpr_passPpr LintPassResultConfig
    cfg)
                                (CoreProgram -> SDoc
    forall b. OutputableBndr b => [Bind b] -> SDoc
    pprCoreBindings CoreProgram
    binds) WarnsAndErrs
    warns_and_errs
           }

    displayLintResults :: Logger
                       -> Bool -- ^ If 'True', display linter warnings.
                               --   If 'False', ignore linter warnings.
                       -> SDoc -- ^ The source of the linted program
                       -> SDoc -- ^ The linted program, pretty-printed
                       -> WarnsAndErrs
                       -> IO ()
    displayLintResults :: Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
    displayLintResults Logger
    logger Bool
    display_warnings SDoc
    pp_what SDoc
    pp_pgm (Bag SDoc
    warns, Bag SDoc
    errs)
      | Bool -> Bool
    not (Bag SDoc -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Bag SDoc
    errs)
      = do { Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    Err.MCInfo SrcSpan
    noSrcSpan  -- See Note [MCInfo for 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 -> SDoc
    lint_banner String
    "errors" SDoc
    pp_what, Bag SDoc -> SDoc
    Err.pprMessageBag Bag SDoc
    errs
                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "*** Offending Program ***"
                     , SDoc
    pp_pgm
                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "*** End of Offense ***" ])
           ; Logger -> JoinArity -> IO ()
    Err.ghcExit Logger
    logger JoinArity
    1 }

      | Bool -> Bool
    not (Bag SDoc -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Bag SDoc
    warns)
      , LogFlags -> Bool
    log_enable_debug (Logger -> LogFlags
    logFlags Logger
    logger)
      , Bool
    display_warnings
      = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    Err.MCInfo SrcSpan
    noSrcSpan  -- See Note [MCInfo for Lint]
          (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle
            (String -> SDoc -> SDoc
    lint_banner String
    "warnings" SDoc
    pp_what SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ Bag SDoc -> SDoc
    Err.pprMessageBag ((SDoc -> SDoc) -> Bag SDoc -> Bag SDoc
    forall a b. (a -> b) -> Bag a -> Bag b
    mapBag (SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    blankLine) Bag SDoc
    warns))

      | Bool
    otherwise = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    lint_banner :: String -> SDoc -> SDoc
    lint_banner :: String -> SDoc -> SDoc
    lint_banner String
    string SDoc
    pass = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "*** Core Lint"      SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    string
                              SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ": in result of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    pass
                              SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "***"

    -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
    lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
    --   Returns (warnings, errors)
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
    lintCoreBindings' LintConfig
    cfg CoreProgram
    binds
      = LintConfig -> LintM ((), [UsageEnv]) -> WarnsAndErrs
    forall a. LintConfig -> LintM a -> WarnsAndErrs
    initL LintConfig
    cfg (LintM ((), [UsageEnv]) -> WarnsAndErrs)
    -> LintM ((), [UsageEnv]) -> WarnsAndErrs
    forall a b. (a -> b) -> a -> b
    $
        LintLocInfo -> LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv])
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc LintLocInfo
    TopLevelBindings           (LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv]))
    -> LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv])
    forall a b. (a -> b) -> a -> b
    $
        do { Bool -> SDoc -> LintM ()
    checkL ([NonEmpty Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [NonEmpty Var]
    dups) ([NonEmpty Var] -> SDoc
    dupVars [NonEmpty Var]
    dups)
           ; Bool -> SDoc -> LintM ()
    checkL ([NonEmpty Name] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [NonEmpty Name]
    ext_dups) ([NonEmpty Name] -> SDoc
    dupExtVars [NonEmpty Name]
    ext_dups)
           ; TopLevelFlag
    -> [(Var, CoreExpr)]
    -> ([Var] -> LintM ())
    -> LintM ((), [UsageEnv])
    forall a.
    TopLevelFlag
    -> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
    lintRecBindings TopLevelFlag
    TopLevel [(Var, CoreExpr)]
    all_pairs (([Var] -> LintM ()) -> LintM ((), [UsageEnv]))
    -> ([Var] -> LintM ()) -> LintM ((), [UsageEnv])
    forall a b. (a -> b) -> a -> b
    $ \[Var]
    _ ->
             () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () }
      where
        all_pairs :: [(Var, CoreExpr)]
    all_pairs = CoreProgram -> [(Var, CoreExpr)]
    forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds CoreProgram
    binds
         -- Put all the top-level binders in scope at the start
         -- This is because rewrite rules can bring something
         -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"
        binders :: [Var]
    binders = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
    forall a b. (a -> b) -> [a] -> [b]
    map (Var, CoreExpr) -> Var
    forall a b. (a, b) -> a
    fst [(Var, CoreExpr)]
    all_pairs

        ([Var]
    _, [NonEmpty Var]
    dups) = (Var -> Var -> Ordering) -> [Var] -> ([Var], [NonEmpty Var])
    forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
    removeDups Var -> Var -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare [Var]
    binders

        -- ext_dups checks for names with different uniques
        -- but the same External name M.n.  We don't
        -- allow this at top level:
        --    M.n{r3}  = ...
        --    M.n{r29} = ...
        -- because they both get the same linker symbol
        ext_dups :: [NonEmpty Name]
    ext_dups = ([Name], [NonEmpty Name]) -> [NonEmpty Name]
    forall a b. (a, b) -> b
    snd (([Name], [NonEmpty Name]) -> [NonEmpty Name])
    -> ([Name], [NonEmpty Name]) -> [NonEmpty Name]
    forall a b. (a -> b) -> a -> b
    $ (Name -> (Module, OccName)) -> [Name] -> ([Name], [NonEmpty Name])
    forall b a. Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])
    removeDupsOn Name -> (Module, OccName)
    ord_ext ([Name] -> ([Name], [NonEmpty Name]))
    -> [Name] -> ([Name], [NonEmpty Name])
    forall a b. (a -> b) -> a -> b
    $
                   (Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Name -> Bool
    isExternalName ([Name] -> [Name]) -> [Name] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ (Var -> Name) -> [Var] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Var -> Name
    Var.varName [Var]
    binders
        ord_ext :: Name -> (Module, OccName)
    ord_ext Name
    n = (HasDebugCallStack => Name -> Module
    Name -> Module
    nameModule Name
    n, Name -> OccName
    nameOccName Name
    n)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[lintUnfolding]{lintUnfolding}
    *                                                                      *
    ************************************************************************

    Note [Linting Unfoldings from Interfaces]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We use this to check all top-level unfoldings that come in from interfaces
    (it is very painful to catch errors otherwise).

    We do not need to call lintUnfolding on unfoldings that are nested within
    top-level unfoldings; they are linted when we lint the top-level unfolding;
    hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.

    -}

    lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding
                  -> LintConfig
                  -> SrcLoc
                  -> CoreExpr
                  -> Maybe (Bag SDoc) -- Nothing => OK

    lintUnfolding :: Bool -> LintConfig -> SrcLoc -> CoreExpr -> Maybe (Bag SDoc)
    lintUnfolding Bool
    is_compulsory LintConfig
    cfg SrcLoc
    locn CoreExpr
    expr
      | Bag SDoc -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Bag SDoc
    errs = Maybe (Bag SDoc)
    forall a. Maybe a
    Nothing
      | Bool
    otherwise       = Bag SDoc -> Maybe (Bag SDoc)
    forall a. a -> Maybe a
    Just Bag SDoc
    errs
      where
        (Bag SDoc
    _warns, Bag SDoc
    errs) = LintConfig -> LintM (LintedType, UsageEnv) -> WarnsAndErrs
    forall a. LintConfig -> LintM a -> WarnsAndErrs
    initL LintConfig
    cfg (LintM (LintedType, UsageEnv) -> WarnsAndErrs)
    -> LintM (LintedType, UsageEnv) -> WarnsAndErrs
    forall a b. (a -> b) -> a -> b
    $
                         if Bool
    is_compulsory
                           -- See Note [Checking for representation polymorphism]
                         then LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    noFixedRuntimeRepChecks LintM (LintedType, UsageEnv)
    linter
                         else LintM (LintedType, UsageEnv)
    linter
        linter :: LintM (LintedType, UsageEnv)
    linter = LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (SrcLoc -> LintLocInfo
    ImportedUnfolding SrcLoc
    locn) (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
                 CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr

    lintExpr :: LintConfig
             -> CoreExpr
             -> Maybe (Bag SDoc)  -- Nothing => OK

    lintExpr :: LintConfig -> CoreExpr -> Maybe (Bag SDoc)
    lintExpr LintConfig
    cfg CoreExpr
    expr
      | Bag SDoc -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Bag SDoc
    errs = Maybe (Bag SDoc)
    forall a. Maybe a
    Nothing
      | Bool
    otherwise       = Bag SDoc -> Maybe (Bag SDoc)
    forall a. a -> Maybe a
    Just Bag SDoc
    errs
      where
        (Bag SDoc
    _warns, Bag SDoc
    errs) = LintConfig -> LintM (LintedType, UsageEnv) -> WarnsAndErrs
    forall a. LintConfig -> LintM a -> WarnsAndErrs
    initL LintConfig
    cfg LintM (LintedType, UsageEnv)
    linter
        linter :: LintM (LintedType, UsageEnv)
    linter = LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc LintLocInfo
    TopLevelBindings (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
                 CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr

    {-
    ************************************************************************
    *                                                                      *
    \subsection[lintCoreBinding]{lintCoreBinding}
    *                                                                      *
    ************************************************************************

    Check a core binding, returning the list of variables bound.
    -}

    -- Returns a UsageEnv because this function is called in lintCoreExpr for
    -- Let

    lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
                    -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv])
    lintRecBindings :: forall a.
    TopLevelFlag
    -> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
    lintRecBindings TopLevelFlag
    top_lvl [(Var, CoreExpr)]
    pairs [Var] -> LintM a
    thing_inside
      = TopLevelFlag
    -> [Var]
    -> ([Var] -> LintM (a, [UsageEnv]))
    -> LintM (a, [UsageEnv])
    forall a. TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintIdBndrs TopLevelFlag
    top_lvl [Var]
    bndrs (([Var] -> LintM (a, [UsageEnv])) -> LintM (a, [UsageEnv]))
    -> ([Var] -> LintM (a, [UsageEnv])) -> LintM (a, [UsageEnv])
    forall a b. (a -> b) -> a -> b
    $ \ [Var]
    bndrs' ->
        do { ues <- (Var -> CoreExpr -> LintM UsageEnv)
    -> [Var] -> [CoreExpr] -> LintM [UsageEnv]
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM Var -> CoreExpr -> LintM UsageEnv
    lint_pair [Var]
    bndrs' [CoreExpr]
    rhss
           ; a <- thing_inside bndrs'
           ; return (a, ues) }
      where
        ([Var]
    bndrs, [CoreExpr]
    rhss) = [(Var, CoreExpr)] -> ([Var], [CoreExpr])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Var, CoreExpr)]
    pairs
        lint_pair :: Var -> CoreExpr -> LintM UsageEnv
    lint_pair Var
    bndr' CoreExpr
    rhs
          = LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    RhsOf Var
    bndr') (LintM UsageEnv -> LintM UsageEnv)
    -> LintM UsageEnv -> LintM UsageEnv
    forall a b. (a -> b) -> a -> b
    $
            do { (rhs_ty, ue) <- Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr' CoreExpr
    rhs         -- Check the rhs
               ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty
               ; return ue }

    lintLetBody :: LintLocInfo -> [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody :: LintLocInfo -> [Var] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody LintLocInfo
    loc [Var]
    bndrs CoreExpr
    body
      = do { (body_ty, body_ue) <- LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc LintLocInfo
    loc (CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    body)
           ; mapM_ (lintJoinBndrType body_ty) bndrs
           ; return (body_ty, body_ue) }

    lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
                  -> CoreExpr -> LintedType -> LintM ()
    -- Binder's type, and the RHS, have already been linted
    -- This function checks other invariants
    lintLetBind :: TopLevelFlag
    -> RecFlag -> Var -> CoreExpr -> LintedType -> LintM ()
    lintLetBind TopLevelFlag
    top_lvl RecFlag
    rec_flag Var
    binder CoreExpr
    rhs LintedType
    rhs_ty
      = do { let binder_ty :: LintedType
    binder_ty = Var -> LintedType
    idType Var
    binder
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    binder_ty LintedType
    rhs_ty (Var -> SDoc -> LintedType -> SDoc
    mkRhsMsg Var
    binder (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "RHS") LintedType
    rhs_ty)

           -- If the binding is for a CoVar, the RHS should be (Coercion co)
           -- See Note [Core type and coercion invariant] in GHC.Core
           ; Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (Var -> Bool
    isCoVar Var
    binder) Bool -> Bool -> Bool
    || CoreExpr -> Bool
    forall b. Expr b -> Bool
    isCoArg CoreExpr
    rhs)
                    (Var -> CoreExpr -> SDoc
    mkLetErr Var
    binder CoreExpr
    rhs)

            -- Check the let-can-float invariant
            -- See Note [Core let-can-float invariant] in GHC.Core
           ; Bool -> SDoc -> LintM ()
    checkL ( Var -> Bool
    isJoinId Var
    binder
                   Bool -> Bool -> Bool
    || LintedType -> Bool
    mightBeLiftedType LintedType
    binder_ty
                   Bool -> Bool -> Bool
    || (RecFlag -> Bool
    isNonRec RecFlag
    rec_flag Bool -> Bool -> Bool
    && CoreExpr -> Bool
    exprOkForSpeculation CoreExpr
    rhs)
                   Bool -> Bool -> Bool
    || Var -> Bool
    isDataConWorkId Var
    binder Bool -> Bool -> Bool
    || Var -> Bool
    isDataConWrapId Var
    binder -- until #17521 is fixed
                   Bool -> Bool -> Bool
    || CoreExpr -> Bool
    exprIsTickedString CoreExpr
    rhs)
               (Var -> SDoc -> SDoc
    badBndrTyMsg Var
    binder (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "unlifted"))

            -- Check that if the binder is at the top level and has type Addr#,
            -- that it is a string literal.
            -- See Note [Core top-level string literals].
           ; Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl Bool -> Bool -> Bool
    && LintedType
    binder_ty HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    addrPrimTy)
                     Bool -> Bool -> Bool
    || CoreExpr -> Bool
    exprIsTickedString CoreExpr
    rhs)
               (Var -> SDoc
    mkTopNonLitStrMsg Var
    binder)

           ; flags <- LintM LintFlags
    getLintFlags

             -- Check that a join-point binder has a valid type
             -- NB: lintIdBinder has checked that it is not top-level bound
           ; case idJoinPointHood binder of
                JoinPointHood
    NotJoinPoint    -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                JoinPoint JoinArity
    arity ->  Bool -> SDoc -> LintM ()
    checkL (JoinArity -> LintedType -> Bool
    isValidJoinPointType JoinArity
    arity LintedType
    binder_ty)
                                           (Var -> LintedType -> SDoc
    mkInvalidJoinPointMsg Var
    binder LintedType
    binder_ty)

           ; when (lf_check_inline_loop_breakers flags
                   && isStableUnfolding (realIdUnfolding binder)
                   && isStrongLoopBreaker (idOccInfo binder)
                   && isInlinePragma (idInlinePragma binder))
                  (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
                  -- Only non-rule loop breakers inhibit inlining

           -- We used to check that the dmdTypeDepth of a demand signature never
           -- exceeds idArity, but that is an unnecessary complication, see
           -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal

           -- Check that the binder's arity is within the bounds imposed by the type
           -- and the strictness signature. See Note [Arity invariants for bindings]
           -- and Note [Trimming arity]

           ; checkL (typeArity (idType binder) >= idArity binder)
               (text "idArity" <+> ppr (idArity binder) <+>
               text "exceeds typeArity" <+>
               ppr (typeArity (idType binder)) <> colon <+>
               ppr binder)

           -- See Note [idArity varies independently of dmdTypeDepth]
           --     in GHC.Core.Opt.DmdAnal
           ; case splitDmdSig (idDmdSig binder) of
               ([Demand]
    demands, Divergence
    result_info) | Divergence -> Bool
    isDeadEndDiv Divergence
    result_info ->
                  if ([Demand]
    demands [Demand] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthAtLeast` Var -> JoinArity
    idArity Var
    binder)
                  then () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                  else String -> SDoc -> LintM () -> LintM ()
    forall a. String -> SDoc -> a -> a
    pprTrace String
    "Hack alert: lintLetBind #24623"
                           (JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> JoinArity
    idArity Var
    binder) SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ DmdSig -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> DmdSig
    idDmdSig Var
    binder)) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                       () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    --             checkL (demands `lengthAtLeast` idArity binder)
    --               (text "idArity" <+> ppr (idArity binder) <+>
    --               text "exceeds arity imposed by the strictness signature" <+>
    --               ppr (idDmdSig binder) <> colon <+>
    --               ppr binder)

               ([Demand], Divergence)
    _ -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

           ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)

           ; addLoc (UnfoldingOf binder) $
             lintIdUnfolding binder binder_ty (idUnfolding binder)
           ; return () }

            -- We should check the unfolding, if any, but this is tricky because
            -- the unfolding is a SimplifiableCoreExpr. Give up for now.

    -- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
    -- in that it doesn't reject occurrences of the function 'makeStatic' when they
    -- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
    -- for join points, it skips the outer lambdas that take arguments to the
    -- join point.
    --
    -- See Note [Checking StaticPtrs].
    lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv)
    -- NB: the Id can be Linted or not -- it's only used for
    --     its OccInfo and join-pointer-hood
    lintRhs :: Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr CoreExpr
    rhs
        | JoinPoint JoinArity
    arity <- Var -> JoinPointHood
    idJoinPointHood Var
    bndr
        = JoinArity -> Maybe Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintJoinLams JoinArity
    arity (Var -> Maybe Var
    forall a. a -> Maybe a
    Just Var
    bndr) CoreExpr
    rhs
        | AlwaysTailCalled JoinArity
    arity <- OccInfo -> TailCallInfo
    tailCallInfo (Var -> OccInfo
    idOccInfo Var
    bndr)
        = JoinArity -> Maybe Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintJoinLams JoinArity
    arity Maybe Var
    forall a. Maybe a
    Nothing CoreExpr
    rhs

    -- Allow applications of the data constructor @StaticPtr@ at the top
    -- but produce errors otherwise.
    lintRhs Var
    _bndr CoreExpr
    rhs = (LintFlags -> StaticPtrCheck)
    -> LintM LintFlags -> LintM StaticPtrCheck
    forall a b. (a -> b) -> LintM a -> LintM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap LintFlags -> StaticPtrCheck
    lf_check_static_ptrs LintM LintFlags
    getLintFlags LintM StaticPtrCheck
    -> (StaticPtrCheck -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a b. LintM a -> (a -> LintM b) -> LintM b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= StaticPtrCheck -> LintM (LintedType, UsageEnv)
    go
      where
        -- Allow occurrences of 'makeStatic' at the top-level but produce errors
        -- otherwise.
        go :: StaticPtrCheck -> LintM (OutType, UsageEnv)
        go :: StaticPtrCheck -> LintM (LintedType, UsageEnv)
    go StaticPtrCheck
    AllowAtTopLevel
          | ([Var]
    binders0, CoreExpr
    rhs') <- CoreExpr -> ([Var], CoreExpr)
    collectTyBinders CoreExpr
    rhs
          , Just (CoreExpr
    fun, LintedType
    t, CoreExpr
    info, CoreExpr
    e) <- CoreExpr -> Maybe (CoreExpr, LintedType, CoreExpr, CoreExpr)
    collectMakeStaticArgs CoreExpr
    rhs'
          = LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
            (Var
     -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    -> [Var]
    -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr
            -- imitate @lintCoreExpr (Lam ...)@
            Var -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    lintLambda
            -- imitate @lintCoreExpr (App ...)@
            (do fun_ty_ue <- CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    fun
                lintCoreArgs fun_ty_ue [Type t, info, e]
            )
            [Var]
    binders0
        go StaticPtrCheck
    _ = LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    rhs

    -- | Lint the RHS of a join point with expected join arity of @n@ (see Note
    -- [Join points] in "GHC.Core").
    lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintJoinLams :: JoinArity -> Maybe Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintJoinLams JoinArity
    join_arity Maybe Var
    enforce CoreExpr
    rhs
      = JoinArity -> CoreExpr -> LintM (LintedType, UsageEnv)
    go JoinArity
    join_arity CoreExpr
    rhs
      where
        go :: JoinArity -> CoreExpr -> LintM (LintedType, UsageEnv)
    go JoinArity
    0 CoreExpr
    expr            = CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr
        go JoinArity
    n (Lam Var
    var CoreExpr
    body)  = Var -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    lintLambda Var
    var (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ JoinArity -> CoreExpr -> LintM (LintedType, UsageEnv)
    go (JoinArity
    nJoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    -JoinArity
    1) CoreExpr
    body
        go JoinArity
    n CoreExpr
    expr | Just Var
    bndr <- Maybe Var
    enforce -- Join point with too few RHS lambdas
                  = SDoc -> LintM (LintedType, UsageEnv)
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM (LintedType, UsageEnv))
    -> SDoc -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ Var -> JoinArity -> JoinArity -> CoreExpr -> SDoc
    mkBadJoinArityMsg Var
    bndr JoinArity
    join_arity JoinArity
    n CoreExpr
    rhs
                  | Bool
    otherwise -- Future join point, not yet eta-expanded
                  = LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr
                    -- Body of lambda is not a tail position

    lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
    lintIdUnfolding :: Var -> LintedType -> Unfolding -> LintM ()
    lintIdUnfolding Var
    bndr LintedType
    bndr_ty Unfolding
    uf
      | Unfolding -> Bool
    isStableUnfolding Unfolding
    uf
      , Just CoreExpr
    rhs <- Unfolding -> Maybe CoreExpr
    maybeUnfoldingTemplate Unfolding
    uf
      = do { ty <- (LintedType, UsageEnv) -> LintedType
    forall a b. (a, b) -> a
    fst ((LintedType, UsageEnv) -> LintedType)
    -> LintM (LintedType, UsageEnv) -> LintM LintedType
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (if Unfolding -> Bool
    isCompulsoryUnfolding Unfolding
    uf
                            then LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    noFixedRuntimeRepChecks (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr CoreExpr
    rhs
                --               ^^^^^^^^^^^^^^^^^^^^^^^
                -- See Note [Checking for representation polymorphism]
                            else Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr CoreExpr
    rhs)
           ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
    lintIdUnfolding  Var
    _ LintedType
    _ Unfolding
    _
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()       -- Do not Lint unstable unfoldings, because that leads
                        -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars

    {- Note [Checking for INLINE loop breakers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It's very suspicious if a strong loop breaker is marked INLINE.

    However, the desugarer generates instance methods with INLINE pragmas
    that form a mutually recursive group.  Only after a round of
    simplification are they unravelled.  So we suppress the test for
    the desugarer.  Here is an example:
      instance Eq T where
        t1 == t2 = blah
        t1 /= t2 = not (t1 == t2)
        {-# INLINE (/=) #-}

    This will generate something like
        -- From the class decl for Eq
        data Eq a = EqDict (a->a->Bool) (a->a->Bool)
        eq_sel :: Eq a -> (a->a->Bool)
        eq_sel (EqDict eq _) = eq

        -- From the instance Eq T
        $ceq :: T -> T -> Bool
        $ceq = blah

        Rec { $dfEqT :: Eq T {-# DFunId #-}
              $dfEqT = EqDict $ceq $cnoteq

              $cnoteq :: T -> T -> Bool  {-# INLINE #-}
              $cnoteq x y = not (eq_sel $dfEqT x y) }

    Notice that

    * `$dfEqT` and `$cnotEq` are mutually recursive.

    * We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and
      we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun
      selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop
      breaker.

    So we make `$cnoteq` into the loop breaker. That means it can't
    inline, despite the INLINE pragma. That's what gives rise to the
    warning, which is perfectly appropriate for, say
       Rec { {-# INLINE f #-}  f = \x -> ...f.... }
    We can't inline a recursive function -- it's a loop breaker.

    But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get
      Rec {
        $dfEqT :: Eq T {-# DFunId #-}
        $dfEqT = EqDict $ceq $cnoteq

        $cnoteq :: T -> T -> Bool  {-# INLINE #-}
        $cnoteq x y = not ($ceq x y) }

    and now the dependencies of the Rec have gone, and we can split it up to give
        NonRec {  $dfEqT :: Eq T {-# DFunId #-}
                  $dfEqT = EqDict $ceq $cnoteq }

        NonRec {  $cnoteq :: T -> T -> Bool  {-# INLINE #-}
                  $cnoteq x y = not ($ceq x y) }

    Now $cnoteq is not a loop breaker any more, so the INLINE pragma can
    take effect -- the warning turned out to be temporary.

    To stop excessive warnings, this warning for INLINE loop breakers is
    switched off when linting the result of the desugarer.  See
    lf_check_inline_loop_breakers in GHC.Core.Lint.

    Note [Checking for representation polymorphism]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We ordinarily want to check for bad representation polymorphism. See
    Note [Representation polymorphism invariants] in GHC.Core. However, we do *not*
    want to do this in a compulsory unfolding. Compulsory unfoldings arise
    only internally, for things like newtype wrappers, dictionaries, and
    (notably) unsafeCoerce#. These might legitimately be representation-polymorphic;
    indeed representation-polymorphic unfoldings are a primary reason for the
    very existence of compulsory unfoldings (we can't compile code for
    the original, representation-polymorphic, binding).

    It is vitally important that we do representation polymorphism checks *after*
    performing the unfolding, but not beforehand. This is all safe because
    we will check any unfolding after it has been unfolded; checking the
    unfolding beforehand is merely an optimization, and one that actively
    hurts us here.

    Note [Linting of runRW#]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    runRW# has some very special behavior (see Note [runRW magic] in
    GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing
    join points in its argument.  For example, this is fine:

        join j x = ...
        in runRW#  (\s. case v of
                           A -> j 3
                           B -> j 4)

    Usually those calls to the join point 'j' would not be valid tail calls,
    because they occur in a function argument.  But in the case of runRW#
    they are fine, because runRW# (\s.e) behaves operationally just like e.
    (runRW# is ultimately inlined in GHC.CoreToStg.Prep.)

    In the case that the continuation is /not/ a lambda we simply disable this
    special behaviour.  For example, this is /not/ fine:

        join j = ...
        in runRW# @r @ty (jump j)

    Note [Coercions in terms]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    The expression (Type ty) can occur only as the argument of an application,
    or the RHS of a non-recursive Let.  But what about (Coercion co)?

    Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose
    definition is:
       coercible_sel :: Coercible a b => (a ~R# b)
       coercible_sel d = case d of
                             MkCoercibleDict (co :: a ~# b) -> Coercion co

    So this function has a (Coercion co) in the alternative of a case.

    Richard says (!11908): it shouldn't appear outside of arguments, but we've been
    loose about this. coercible_sel is some thin ice. Really we should be unpacking
    Coercible using case, not a selector. I recall looking into this a few years
    back and coming to the conclusion that the fix was worse than the disease. Don't
    remember the details, but could probably recover it if we want to revisit.

    So Lint current accepts (Coercion co) in arbitrary places.  There is no harm in
    that: it really is a value, albeit a zero-bit value.

    ************************************************************************
    *                                                                      *
    \subsection[lintCoreExpr]{lintCoreExpr}
    *                                                                      *
    ************************************************************************
    -}

    -- Linted things: substitution applied, and type is linted
    type LintedType     = Type
    type LintedKind     = Kind
    type LintedCoercion = Coercion
    type LintedTyCoVar  = TyCoVar
    type LintedId       = Id

    -- | Lint an expression cast through the given coercion, returning the type
    -- resulting from the cast.
    lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType
    lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType
    lintCastExpr CoreExpr
    expr LintedType
    expr_ty Coercion
    co
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let (Pair from_ty to_ty, role) = coercionKindRole co'
           ; checkValueType to_ty $
             text "target of cast" <+> quotes (ppr co')
           ; lintRole co' Representational role
           ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
           ; return to_ty }

    lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv)
    -- The returned type has the substitution from the monad
    -- already applied to it:
    --      lintCoreExpr e subst = exprType (subst e)
    --
    -- The returned "type" can be a kind, if the expression is (Type ty)

    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]

    lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr (Var Var
    var)
      = do
          var_pair@(var_ty, _) <- Var -> JoinArity -> LintM (LintedType, UsageEnv)
    lintIdOcc Var
    var JoinArity
    0
          -- See Note [Linting representation-polymorphic builtins]
          checkRepPolyBuiltin (Var var) [] var_ty
          --checkDataToTagPrimOpTyCon (Var var) []
          return var_pair

    lintCoreExpr (Lit Literal
    lit)
      = (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Literal -> LintedType
    literalType Literal
    lit, UsageEnv
    zeroUE)

    lintCoreExpr (Cast CoreExpr
    expr Coercion
    co)
      = do (expr_ty, ue) <- LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr)
                -- markAllJoinsBad: see Note [Join points and casts]
           to_ty <- lintCastExpr expr expr_ty co
           return (to_ty, ue)

    lintCoreExpr (Tick CoreTickish
    tickish CoreExpr
    expr)
      = do case CoreTickish
    tickish of
             Breakpoint XBreakpoint 'TickishPassCore
    _ JoinArity
    _ [XTickishId 'TickishPassCore]
    ids Module
    _ -> [Var] -> (Var -> LintM (Var, LintedType)) -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Var]
    [XTickishId 'TickishPassCore]
    ids ((Var -> LintM (Var, LintedType)) -> LintM ())
    -> (Var -> LintM (Var, LintedType)) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \Var
    id -> do
                                       Var -> LintM ()
    checkDeadIdOcc Var
    id
                                       Var -> LintM (Var, LintedType)
    lookupIdInScope Var
    id
             CoreTickish
    _                    -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
           Bool
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. Bool -> LintM a -> LintM a
    markAllJoinsBadIf Bool
    block_joins (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr
      where
        block_joins :: Bool
    block_joins = Bool -> Bool
    not (CoreTickish
    tickish CoreTickish -> TickishScoping -> Bool
    forall (pass :: TickishPass).
    GenTickish pass -> TickishScoping -> Bool
    `tickishScopesLike` TickishScoping
    SoftScope)
          -- TODO Consider whether this is the correct rule. It is consistent with
          -- the simplifier's behaviour - cost-centre-scoped ticks become part of
          -- the continuation, and thus they behave like part of an evaluation
          -- context, but soft-scoped and non-scoped ticks simply wrap the result
          -- (see Simplify.simplTick).

    lintCoreExpr (Let (NonRec Var
    tv (Type LintedType
    ty)) CoreExpr
    body)
      | Var -> Bool
    isTyVar Var
    tv
      =     -- See Note [Linting type lets]
        do  { ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
            ; lintTyBndr tv              $ \ Var
    tv' ->
        do  { LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    RhsOf Var
    tv) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ Var -> LintedType -> LintM ()
    lintTyKind Var
    tv' LintedType
    ty'
                    -- Now extend the substitution so we
                    -- take advantage of it in the body
            ; Var
    -> LintedType
    -> LintM (LintedType, UsageEnv)
    -> LintM (LintedType, UsageEnv)
    forall a. Var -> LintedType -> LintM a -> LintM a
    extendTvSubstL Var
    tv LintedType
    ty'        (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
              LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    BodyOfLet Var
    tv) (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
              CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    body } }

    lintCoreExpr (Let (NonRec Var
    bndr CoreExpr
    rhs) CoreExpr
    body)
      | Var -> Bool
    isId Var
    bndr
      = do { -- First Lint the RHS, before bringing the binder into scope
             (rhs_ty, let_ue) <- Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr CoreExpr
    rhs

              -- See Note [Multiplicity of let binders] in Var
             -- Now lint the binder
           ; lintBinder LetBind bndr $ \Var
    bndr' ->
        do { TopLevelFlag
    -> RecFlag -> Var -> CoreExpr -> LintedType -> LintM ()
    lintLetBind TopLevelFlag
    NotTopLevel RecFlag
    NonRecursive Var
    bndr' CoreExpr
    rhs LintedType
    rhs_ty
           ; Var
    -> UsageEnv
    -> LintM (LintedType, UsageEnv)
    -> LintM (LintedType, UsageEnv)
    forall a. Var -> UsageEnv -> LintM a -> LintM a
    addAliasUE Var
    bndr UsageEnv
    let_ue (LintLocInfo -> [Var] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody (Var -> LintLocInfo
    BodyOfLet Var
    bndr') [Var
    bndr'] CoreExpr
    body) } }

      | Bool
    otherwise
      = SDoc -> LintM (LintedType, UsageEnv)
    forall a. SDoc -> LintM a
    failWithL (Var -> CoreExpr -> SDoc
    mkLetErr Var
    bndr CoreExpr
    rhs)       -- Not quite accurate

    lintCoreExpr e :: CoreExpr
    e@(Let (Rec [(Var, CoreExpr)]
    pairs) CoreExpr
    body)
      = do  { -- Check that the list of pairs is non-empty
              Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not ([(Var, CoreExpr)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(Var, CoreExpr)]
    pairs)) (CoreExpr -> SDoc
    emptyRec CoreExpr
    e)

              -- Check that there are no duplicated binders
            ; let ([Var]
    _, [NonEmpty Var]
    dups) = (Var -> Var -> Ordering) -> [Var] -> ([Var], [NonEmpty Var])
    forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
    removeDups Var -> Var -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare [Var]
    bndrs
            ; Bool -> SDoc -> LintM ()
    checkL ([NonEmpty Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [NonEmpty Var]
    dups) ([NonEmpty Var] -> SDoc
    dupVars [NonEmpty Var]
    dups)

              -- Check that either all the binders are joins, or none
            ; Bool -> SDoc -> LintM ()
    checkL ((Var -> Bool) -> [Var] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Var -> Bool
    isJoinId [Var]
    bndrs Bool -> Bool -> Bool
    || (Var -> Bool) -> [Var] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Bool -> Bool
    not (Bool -> Bool) -> (Var -> Bool) -> Var -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Var -> Bool
    isJoinId) [Var]
    bndrs) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
              [Var] -> SDoc
    mkInconsistentRecMsg [Var]
    bndrs

              -- See Note [Multiplicity of let binders] in Var
            ; ((body_type, body_ue), ues) <-
                TopLevelFlag
    -> [(Var, CoreExpr)]
    -> ([Var] -> LintM (LintedType, UsageEnv))
    -> LintM ((LintedType, UsageEnv), [UsageEnv])
    forall a.
    TopLevelFlag
    -> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
    lintRecBindings TopLevelFlag
    NotTopLevel [(Var, CoreExpr)]
    pairs (([Var] -> LintM (LintedType, UsageEnv))
     -> LintM ((LintedType, UsageEnv), [UsageEnv]))
    -> ([Var] -> LintM (LintedType, UsageEnv))
    -> LintM ((LintedType, UsageEnv), [UsageEnv])
    forall a b. (a -> b) -> a -> b
    $ \ [Var]
    bndrs' ->
                LintLocInfo -> [Var] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody ([Var] -> LintLocInfo
    BodyOfLetRec [Var]
    bndrs') [Var]
    bndrs' CoreExpr
    body
            ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1 addUE ues)) }
      where
        bndrs :: [Var]
    bndrs = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
    forall a b. (a -> b) -> [a] -> [b]
    map (Var, CoreExpr) -> Var
    forall a b. (a, b) -> a
    fst [(Var, CoreExpr)]
    pairs

    lintCoreExpr e :: CoreExpr
    e@(App CoreExpr
    _ CoreExpr
    _)
      | Var Var
    fun <- CoreExpr
    fun
      , Var
    fun Var -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    runRWKey
        -- N.B. we may have an over-saturated application of the form:
        --   runRW (\s -> \x -> ...) y
      , CoreExpr
    ty_arg1 : CoreExpr
    ty_arg2 : CoreExpr
    arg3 : [CoreExpr]
    rest <- [CoreExpr]
    args
      = do { fun_pair1      <- (LintedType, UsageEnv) -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreArg (Var -> LintedType
    idType Var
    fun, UsageEnv
    zeroUE) CoreExpr
    ty_arg1
           ; (fun_ty2, ue2) <- lintCoreArg fun_pair1            ty_arg2
             -- See Note [Linting of runRW#]
           ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
                 lintRunRWCont expr :: CoreExpr
    expr@(Lam Var
    _ CoreExpr
    _) =
                    JoinArity -> Maybe Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintJoinLams JoinArity
    1 (Var -> Maybe Var
    forall a. a -> Maybe a
    Just Var
    fun) CoreExpr
    expr
                 lintRunRWCont CoreExpr
    other = LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    other
                 -- TODO: Look through ticks?
           ; (arg3_ty, ue3) <- lintRunRWCont arg3
           ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3
           ; lintCoreArgs app_ty rest }

      | Bool
    otherwise
      = do { fun_pair <- CoreExpr -> JoinArity -> LintM (LintedType, UsageEnv)
    lintCoreFun CoreExpr
    fun ([CoreExpr] -> JoinArity
    forall a. [a] -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [CoreExpr]
    args)
           ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args

           -- See Note [Linting representation-polymorphic builtins]
           ; checkRepPolyBuiltin fun args app_ty
           ; --checkDataToTagPrimOpTyCon fun args

           ; return app_pair}
      where
        skipTick :: CoreTickish -> Bool
    skipTick CoreTickish
    t = case CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b
    collectFunSimple CoreExpr
    e of
          (Var Var
    v) -> Var -> CoreTickish -> Bool
    forall (pass :: TickishPass). Var -> GenTickish pass -> Bool
    etaExpansionTick Var
    v CoreTickish
    t
          CoreExpr
    _ -> CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable CoreTickish
    t
        (CoreExpr
    fun, [CoreExpr]
    args, [CoreTickish]
    _source_ticks) = (CoreTickish -> Bool)
    -> CoreExpr -> (CoreExpr, [CoreExpr], [CoreTickish])
    forall b.
    (CoreTickish -> Bool)
    -> Expr b -> (Expr b, [Expr b], [CoreTickish])
    collectArgsTicks CoreTickish -> Bool
    skipTick CoreExpr
    e
          -- We must look through source ticks to avoid #21152, for example:
          --
          -- reallyUnsafePtrEquality
          --   = \ @a ->
          --       (src<loc> reallyUnsafePtrEquality#)
          --         @Lifted @a @Lifted @a
          --
          -- To do this, we use `collectArgsTicks tickishFloatable` to match
          -- the eta expansion behaviour, as per Note [Eta expansion and source notes]
          -- in GHC.Core.Opt.Arity.
          -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.
          -- See Note [Ticks and mandatory eta expansion]

    lintCoreExpr (Lam Var
    var CoreExpr
    expr)
      = LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
        Var -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    lintLambda Var
    var (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr

    lintCoreExpr (Case CoreExpr
    scrut Var
    var LintedType
    alt_ty [Alt Var]
    alts)
      = CoreExpr
    -> Var -> LintedType -> [Alt Var] -> LintM (LintedType, UsageEnv)
    lintCaseExpr CoreExpr
    scrut Var
    var LintedType
    alt_ty [Alt Var]
    alts

    -- This case can't happen; linting types in expressions gets routed through
    -- lintCoreArgs
    lintCoreExpr (Type LintedType
    ty)
      = SDoc -> LintM (LintedType, UsageEnv)
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Type found as expression" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)

    lintCoreExpr (Coercion Coercion
    co)
      -- See Note [Coercions in terms]
      = do { co' <- LintLocInfo -> LintM Coercion -> LintM Coercion
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Coercion -> LintLocInfo
    InCo Coercion
    co) (LintM Coercion -> LintM Coercion)
    -> LintM Coercion -> LintM Coercion
    forall a b. (a -> b) -> a -> b
    $
                    Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; return (coercionType co', zeroUE) }

    ----------------------
    lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed
              -> LintM (LintedType, UsageEnv) -- returns type of the *variable*
    lintIdOcc :: Var -> JoinArity -> LintM (LintedType, UsageEnv)
    lintIdOcc Var
    var JoinArity
    nargs
      = LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    OccOf Var
    var) (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
        do  { Bool -> SDoc -> LintM ()
    checkL (Var -> Bool
    isNonCoVarId Var
    var)
                     (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non term variable" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var)
                     -- See GHC.Core Note [Variable occurrences in Core]

            -- Check that the type of the occurrence is the same
            -- as the type of the binding site.  The inScopeIds are
            -- /un-substituted/, so this checks that the occurrence type
            -- is identical to the binder type.
            -- This makes things much easier for things like:
            --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...
            -- The "::Maybe a" on the occurrence is referring to the /outer/ a.
            -- If we compared /substituted/ types we'd risk comparing
            -- (Maybe a) from the binding site with bogus (Maybe a1) from
            -- the occurrence site.  Comparing un-substituted types finesses
            -- this altogether
            ; (bndr, linted_bndr_ty) <- Var -> LintM (Var, LintedType)
    lookupIdInScope Var
    var
            ; let occ_ty  = Var -> LintedType
    idType Var
    var
                  bndr_ty = Var -> LintedType
    idType Var
    bndr
            ; ensureEqTys occ_ty bndr_ty $
              mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty

              -- Check for a nested occurrence of the StaticPtr constructor.
              -- See Note [Checking StaticPtrs].
            ; lf <- getLintFlags
            ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
                checkL (idName var /= makeStaticName) $
                  text "Found makeStatic nested in an expression"

            ; checkDeadIdOcc var
            ; checkJoinOcc var nargs
            ; case isDataConId_maybe var of
                 Maybe DataCon
    Nothing -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                 Just DataCon
    dc -> String -> DataCon -> LintM ()
    checkTypeDataConOcc String
    "expression" DataCon
    dc

            ; usage <- varCallSiteUsage var

            ; return (linted_bndr_ty, usage) }

    lintCoreFun :: CoreExpr
                -> Int                          -- Number of arguments (type or val) being passed
                -> LintM (LintedType, UsageEnv) -- Returns type of the *function*
    lintCoreFun :: CoreExpr -> JoinArity -> LintM (LintedType, UsageEnv)
    lintCoreFun (Var Var
    var) JoinArity
    nargs
      = Var -> JoinArity -> LintM (LintedType, UsageEnv)
    lintIdOcc Var
    var JoinArity
    nargs

    lintCoreFun (Lam Var
    var CoreExpr
    body) JoinArity
    nargs
      -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;
      -- See Note [Beta redexes]
      | JoinArity
    nargs JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    /= JoinArity
    0
      = Var -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    lintLambda Var
    var (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> JoinArity -> LintM (LintedType, UsageEnv)
    lintCoreFun CoreExpr
    body (JoinArity
    nargs JoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    - JoinArity
    1)

    lintCoreFun CoreExpr
    expr JoinArity
    nargs
      = Bool
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. Bool -> LintM a -> LintM a
    markAllJoinsBadIf (JoinArity
    nargs JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    /= JoinArity
    0) (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
          -- See Note [Join points are less general than the paper]
        CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr
    ------------------
    lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
    lintLambda :: Var -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    lintLambda Var
    var LintM (LintedType, UsageEnv)
    lintBody =
        LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    LambdaBodyOf Var
    var) (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $
        BindingSite
    -> Var
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintBinder BindingSite
    LambdaBind Var
    var ((Var -> LintM (LintedType, UsageEnv))
     -> LintM (LintedType, UsageEnv))
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ \ Var
    var' ->
        do { (body_ty, ue) <- LintM (LintedType, UsageEnv)
    lintBody
           ; ue' <- checkLinearity ue var'
           ; return (mkLamType var' body_ty, ue') }
    ------------------
    checkDeadIdOcc :: Id -> LintM ()
    -- Occurrences of an Id should never be dead....
    -- except when we are checking a case pattern
    checkDeadIdOcc :: Var -> LintM ()
    checkDeadIdOcc Var
    id
      | OccInfo -> Bool
    isDeadOcc (Var -> OccInfo
    idOccInfo Var
    id)
      = do { in_case <- LintM Bool
    inCasePat
           ; checkL in_case
                    (text "Occurrence of a dead Id" <+> ppr id) }
      | Bool
    otherwise
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    ------------------
    lintJoinBndrType :: LintedType -- Type of the body
                     -> LintedId   -- Possibly a join Id
                    -> LintM ()
    -- Checks that the return type of a join Id matches the body
    -- E.g. join j x = rhs in body
    --      The type of 'rhs' must be the same as the type of 'body'
    lintJoinBndrType :: LintedType -> Var -> LintM ()
    lintJoinBndrType LintedType
    body_ty Var
    bndr
      | JoinPoint JoinArity
    arity <- Var -> JoinPointHood
    idJoinPointHood Var
    bndr
      , let bndr_ty :: LintedType
    bndr_ty = Var -> LintedType
    idType Var
    bndr
      , ([PiTyBinder]
    bndrs, LintedType
    res) <- LintedType -> ([PiTyBinder], LintedType)
    splitPiTys LintedType
    bndr_ty
      = Bool -> SDoc -> LintM ()
    checkL ([PiTyBinder] -> JoinArity
    forall a. [a] -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [PiTyBinder]
    bndrs JoinArity -> JoinArity -> Bool
    forall a. Ord a => a -> a -> Bool
    >= JoinArity
    arity
                Bool -> Bool -> Bool
    && LintedType
    body_ty HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` [PiTyBinder] -> LintedType -> LintedType
    HasDebugCallStack => [PiTyBinder] -> LintedType -> LintedType
    mkPiTys (JoinArity -> [PiTyBinder] -> [PiTyBinder]
    forall a. JoinArity -> [a] -> [a]
    drop JoinArity
    arity [PiTyBinder]
    bndrs) LintedType
    res) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join point returns different type than body")
           JoinArity
    2 ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join bndr:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    bndr)
                   , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    arity
                   , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Body type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    body_ty ])
      | Bool
    otherwise
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    checkJoinOcc :: Id -> JoinArity -> LintM ()
    -- Check that if the occurrence is a JoinId, then so is the
    -- binding site, and it's a valid join Id
    checkJoinOcc :: Var -> JoinArity -> LintM ()
    checkJoinOcc Var
    var JoinArity
    n_args
      | JoinPoint JoinArity
    join_arity_occ <- Var -> JoinPointHood
    idJoinPointHood Var
    var
      = do { mb_join_arity_bndr <- Var -> LintM JoinPointHood
    lookupJoinId Var
    var
           ; case mb_join_arity_bndr of {
               JoinPointHood
    NotJoinPoint -> do { join_set <- LintM IdSet
    getValidJoins
                                  ; addErrL (text "join set " <+> ppr join_set $$
                                    invalidJoinOcc var) } ;

               JoinPoint JoinArity
    join_arity_bndr ->

        do { Bool -> SDoc -> LintM ()
    checkL (JoinArity
    join_arity_bndr JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    == JoinArity
    join_arity_occ) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
               -- Arity differs at binding site and occurrence
             Var -> JoinArity -> JoinArity -> SDoc
    mkJoinBndrOccMismatchMsg Var
    var JoinArity
    join_arity_bndr JoinArity
    join_arity_occ

           ; Bool -> SDoc -> LintM ()
    checkL (JoinArity
    n_args JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    == JoinArity
    join_arity_occ) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
               -- Arity doesn't match #args
             Var -> JoinArity -> JoinArity -> SDoc
    mkBadJumpMsg Var
    var JoinArity
    join_arity_occ JoinArity
    n_args } } }

      | Bool
    otherwise
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    checkTypeDataConOcc :: String -> DataCon -> LintM ()
    -- Check that the Id is not a data constructor of a `type data` declaration
    -- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module
    checkTypeDataConOcc :: String -> DataCon -> LintM ()
    checkTypeDataConOcc String
    what DataCon
    dc
      = Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (TyCon -> Bool
    isTypeDataTyCon (DataCon -> TyCon
    dataConTyCon DataCon
    dc))) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "type data constructor found in a" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    what SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    dc)

    {-
    -- | Check that a use of a dataToTag# primop satisfies conditions DTT2
    -- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class
    --
    -- Ignores applications not headed by dataToTag# primops.

    -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet.
    -- See wrinkle DTW7 in Note [DataToTag overview].
    checkDataToTagPrimOpTyCon
      :: CoreExpr   -- ^ the function (head of the application) we are checking
      -> [CoreArg]  -- ^ The arguments to the application
      -> LintM ()
    checkDataToTagPrimOpTyCon (Var fun_id) args
      | Just op <- isPrimOpId_maybe fun_id
      , op == DataToTagSmallOp || op == DataToTagLargeOp
      = case args of
          Type _levity : Type dty : _rest
            | Just (tc, _) <- splitTyConApp_maybe dty
            , isValidDTT2TyCon tc
              -> do  platform <- getPlatform
                     let  numConstrs = tyConFamilySize tc
                          isSmallOp = op == DataToTagSmallOp
                     checkL (isSmallFamily platform numConstrs == isSmallOp) $
                       text "dataToTag# primop-size/tycon-family-size mismatch"
            | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:"
                                       <+> ppr dty
          _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:"
                           <+> ppr (take 2 args)

    checkDataToTagPrimOpTyCon _ _ = pure ()
    -}

    -- | Check representation-polymorphic invariants in an application of a
    -- built-in function or newtype constructor.
    --
    -- See Note [Linting representation-polymorphic builtins].
    checkRepPolyBuiltin :: CoreExpr   -- ^ the function (head of the application) we are checking
                        -> [CoreArg]  -- ^ the arguments to the application
                        -> LintedType -- ^ the instantiated type of the overall application
                        -> LintM ()
    checkRepPolyBuiltin :: CoreExpr -> [CoreExpr] -> LintedType -> LintM ()
    checkRepPolyBuiltin (Var Var
    fun_id) [CoreExpr]
    args LintedType
    app_ty
      = do { do_rep_poly_checks <- LintFlags -> Bool
    lf_check_fixed_rep (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LintM LintFlags
    getLintFlags
           ; when (do_rep_poly_checks && hasNoBinding fun_id) $
               if
                 -- (2) representation-polymorphic unlifted newtypes
                 | Just dc <- isDataConId_maybe fun_id
                 , isNewDataCon dc
                 -> if tcHasFixedRuntimeRep $ dataConTyCon dc
                    then return ()
                    else checkRepPolyNewtypeApp dc args app_ty

                 -- (1) representation-polymorphic builtins
                 | otherwise
                 -> checkRepPolyBuiltinApp fun_id args
           }
    checkRepPolyBuiltin CoreExpr
    _ [CoreExpr]
    _ LintedType
    _ = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> LintedType -> LintM ()
    checkRepPolyNewtypeApp :: DataCon -> [CoreExpr] -> LintedType -> LintM ()
    checkRepPolyNewtypeApp DataCon
    nt [CoreExpr]
    args LintedType
    app_ty
      -- If the newtype is saturated, we're OK.
      | (CoreExpr -> Bool) -> [CoreExpr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any CoreExpr -> Bool
    forall b. Expr b -> Bool
    isValArg [CoreExpr]
    args
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      -- Otherwise, check we can eta-expand.
      | Bool
    otherwise
      = case LintedType -> [(Scaled LintedType, FunTyFlag)]
    getRuntimeArgTys LintedType
    app_ty of
          (Scaled LintedType
    _ LintedType
    first_val_arg_ty, FunTyFlag
    _):[(Scaled LintedType, FunTyFlag)]
    _
            | Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack => LintedType -> Bool
    LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    first_val_arg_ty
            -> SDoc -> LintM ()
    forall a. SDoc -> LintM a
    failWithL (LintedType -> SDoc
    err_msg LintedType
    first_val_arg_ty)
          [(Scaled LintedType, FunTyFlag)]
    _ -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

      where

          err_msg :: Type -> SDoc
          err_msg :: LintedType -> SDoc
    err_msg LintedType
    bad_arg_ty
            = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Cannot eta expand unlifted newtype constructor" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    nt) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    dot
                   , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Its argument type does not have a fixed runtime representation:"
                   , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ LintedType -> SDoc
    ppr_ty_ki LintedType
    bad_arg_ty ]

          ppr_ty_ki :: Type -> SDoc
          ppr_ty_ki :: LintedType -> SDoc
    ppr_ty_ki LintedType
    ty = SDoc
    bullet SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty)

    checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM ()
    checkRepPolyBuiltinApp :: Var -> [CoreExpr] -> LintM ()
    checkRepPolyBuiltinApp Var
    fun_id [CoreExpr]
    args = Bool -> SDoc -> LintM ()
    checkL ([(SDoc, ConcreteTvOrigin)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(SDoc, ConcreteTvOrigin)]
    not_concs) SDoc
    err_msg
      where

        conc_binder_positions :: IntMap ConcreteTvOrigin
        conc_binder_positions :: IntMap ConcreteTvOrigin
    conc_binder_positions
          = Var -> ConcreteTyVars -> IntMap ConcreteTvOrigin
    concreteTyVarPositions Var
    fun_id
          (ConcreteTyVars -> IntMap ConcreteTvOrigin)
    -> ConcreteTyVars -> IntMap ConcreteTvOrigin
    forall a b. (a -> b) -> a -> b
    $ IdDetails -> ConcreteTyVars
    idDetailsConcreteTvs
          (IdDetails -> ConcreteTyVars) -> IdDetails -> ConcreteTyVars
    forall a b. (a -> b) -> a -> b
    $ Var -> IdDetails
    idDetails Var
    fun_id

        max_pos :: Int
        max_pos :: JoinArity
    max_pos =
          case IntMap ConcreteTvOrigin -> [JoinArity]
    forall a. IntMap a -> [JoinArity]
    IntMap.keys IntMap ConcreteTvOrigin
    conc_binder_positions of
            [] -> JoinArity
    0
            [JoinArity]
    positions -> [JoinArity] -> JoinArity
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [JoinArity]
    positions

        not_concs :: [(SDoc, ConcreteTvOrigin)]
        not_concs :: [(SDoc, ConcreteTvOrigin)]
    not_concs =
          ((JoinArity, Maybe CoreExpr) -> Maybe (SDoc, ConcreteTvOrigin))
    -> [(JoinArity, Maybe CoreExpr)] -> [(SDoc, ConcreteTvOrigin)]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (JoinArity, Maybe CoreExpr) -> Maybe (SDoc, ConcreteTvOrigin)
    is_bad ([JoinArity] -> [Maybe CoreExpr] -> [(JoinArity, Maybe CoreExpr)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [JoinArity
    1..JoinArity
    max_pos] ((CoreExpr -> Maybe CoreExpr) -> [CoreExpr] -> [Maybe CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map CoreExpr -> Maybe CoreExpr
    forall a. a -> Maybe a
    Just [CoreExpr]
    args [Maybe CoreExpr] -> [Maybe CoreExpr] -> [Maybe CoreExpr]
    forall a. [a] -> [a] -> [a]
    ++ Maybe CoreExpr -> [Maybe CoreExpr]
    forall a. a -> [a]
    repeat Maybe CoreExpr
    forall a. Maybe a
    Nothing))
            -- NB: 1-indexed

        is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin)
        is_bad :: (JoinArity, Maybe CoreExpr) -> Maybe (SDoc, ConcreteTvOrigin)
    is_bad (JoinArity
    pos, Maybe CoreExpr
    mb_arg)
          | Just ConcreteTvOrigin
    conc_reason <- JoinArity -> IntMap ConcreteTvOrigin -> Maybe ConcreteTvOrigin
    forall a. JoinArity -> IntMap a -> Maybe a
    IntMap.lookup JoinArity
    pos IntMap ConcreteTvOrigin
    conc_binder_positions
          , Just SDoc
    bad_ty <- case Maybe CoreExpr
    mb_arg of
              Just (Type LintedType
    ki)
                | LintedType -> Bool
    isConcreteType LintedType
    ki
                -> Maybe SDoc
    forall a. Maybe a
    Nothing
                | Bool
    otherwise
                -- Here we handle the situation in which a "must be concrete" TyVar
                -- has been instantiated with a type that is not concrete.
                -> SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> SDoc
    quotes (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ki) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "is not concrete."
              -- We expected a type argument in this position, and got something else: panic!
              Just CoreExpr
    arg ->
                String -> SDoc -> Maybe SDoc
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "checkRepPolyBuiltinApp: expected a type in this position" (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
    forall a b. (a -> b) -> a -> b
    $
                  [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "fun_id:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    fun_id SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    fun_id)
                       , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "pos:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    pos
                       , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "arg:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    arg ]
              Maybe CoreExpr
    Nothing ->
                -- Here we handle the situation in which a "must be concrete" TyVar
                -- has not been instantiated at all.
                case ConcreteTvOrigin
    conc_reason of
                  ConcreteFRR FixedRuntimeRepOrigin
    frr_orig ->
                    let ty :: LintedType
    ty = FixedRuntimeRepOrigin -> LintedType
    frr_type FixedRuntimeRepOrigin
    frr_orig
                    in  SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
    forall a b. (a -> b) -> a -> b
    $ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty)
          = (SDoc, ConcreteTvOrigin) -> Maybe (SDoc, ConcreteTvOrigin)
    forall a. a -> Maybe a
    Just (SDoc
    bad_ty, ConcreteTvOrigin
    conc_reason)
          | Bool
    otherwise
          = Maybe (SDoc, ConcreteTvOrigin)
    forall a. Maybe a
    Nothing

        err_msg :: SDoc
        err_msg :: SDoc
    err_msg
          = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ ((SDoc, ConcreteTvOrigin) -> SDoc)
    -> [(SDoc, ConcreteTvOrigin)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map ((SDoc
    bullet SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>) (SDoc -> SDoc)
    -> ((SDoc, ConcreteTvOrigin) -> SDoc)
    -> (SDoc, ConcreteTvOrigin)
    -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (SDoc, ConcreteTvOrigin) -> SDoc
    ppr_not_conc) [(SDoc, ConcreteTvOrigin)]
    not_concs

        ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc
        ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc
    ppr_not_conc (SDoc
    bad_ty, ConcreteTvOrigin
    conc) =
          [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat
           [ ConcreteTvOrigin -> SDoc
    ppr_conc_orig ConcreteTvOrigin
    conc
           , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 SDoc
    bad_ty ]

        ppr_conc_orig :: ConcreteTvOrigin -> SDoc
        ppr_conc_orig :: ConcreteTvOrigin -> SDoc
    ppr_conc_orig (ConcreteFRR FixedRuntimeRepOrigin
    frr_orig) =
          case FixedRuntimeRepOrigin
    frr_orig of
            FixedRuntimeRepOrigin { frr_context :: FixedRuntimeRepOrigin -> FixedRuntimeRepContext
    frr_context = FixedRuntimeRepContext
    ctxt } ->
              [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [ FixedRuntimeRepContext -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FixedRuntimeRepContext
    ctxt, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "does not have a fixed runtime representation:" ]

    -- | Compute the 1-indexed positions in the outer forall'd quantified type variables
    -- of the type in which the concrete type variables occur.
    --
    -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.
    concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin
    concreteTyVarPositions :: Var -> ConcreteTyVars -> IntMap ConcreteTvOrigin
    concreteTyVarPositions Var
    fun_id ConcreteTyVars
    conc_tvs
      | ConcreteTyVars -> Bool
    forall {k} (key :: k) elt. UniqFM key elt -> Bool
    isNullUFM ConcreteTyVars
    conc_tvs
      = IntMap ConcreteTvOrigin
    forall a. IntMap a
    IntMap.empty
      | Bool
    otherwise
      = case LintedType -> ([Var], LintedType)
    splitForAllTyCoVars (Var -> LintedType
    idType Var
    fun_id) of
        ([], LintedType
    _)  -> IntMap ConcreteTvOrigin
    forall a. IntMap a
    IntMap.empty
        ([Var]
    tvs, LintedType
    _) ->
          let positions :: IntMap ConcreteTvOrigin
    positions =
                [(JoinArity, ConcreteTvOrigin)] -> IntMap ConcreteTvOrigin
    forall a. [(JoinArity, a)] -> IntMap a
    IntMap.fromList
                  [ (JoinArity
    pos, ConcreteTvOrigin
    conc_orig)
                  | (Var
    tv, JoinArity
    pos) <- [Var] -> [JoinArity] -> [(Var, JoinArity)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Var]
    tvs [JoinArity
    1..]
                  , ConcreteTvOrigin
    conc_orig <- Maybe ConcreteTvOrigin -> [ConcreteTvOrigin]
    forall a. Maybe a -> [a]
    maybeToList (Maybe ConcreteTvOrigin -> [ConcreteTvOrigin])
    -> Maybe ConcreteTvOrigin -> [ConcreteTvOrigin]
    forall a b. (a -> b) -> a -> b
    $ ConcreteTyVars -> Name -> Maybe ConcreteTvOrigin
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv ConcreteTyVars
    conc_tvs (Var -> Name
    tyVarName Var
    tv)
                  ]
             -- Assert that we have as many positions as concrete type variables,
             -- i.e. we are not missing any concreteness information.
          in Bool -> SDoc -> IntMap ConcreteTvOrigin -> IntMap ConcreteTvOrigin
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (ConcreteTyVars -> JoinArity
    forall {k} (key :: k) elt. UniqFM key elt -> JoinArity
    sizeUFM ConcreteTyVars
    conc_tvs JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    == IntMap ConcreteTvOrigin -> JoinArity
    forall a. IntMap a -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length IntMap ConcreteTvOrigin
    positions)
               ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "concreteTyVarPositions: missing concreteness information"
                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "fun_id:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    fun_id
                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "tvs:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Var]
    tvs
                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Expected # of concrete tvs:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (ConcreteTyVars -> JoinArity
    forall {k} (key :: k) elt. UniqFM key elt -> JoinArity
    sizeUFM ConcreteTyVars
    conc_tvs)
                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "  Actual # of concrete tvs:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (IntMap ConcreteTvOrigin -> JoinArity
    forall a. IntMap a -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length IntMap ConcreteTvOrigin
    positions) ])
               IntMap ConcreteTvOrigin
    positions

    -- Check that the usage of var is consistent with var itself, and pop the var
    -- from the usage environment (this is important because of shadowing).
    checkLinearity :: UsageEnv -> Var -> LintM UsageEnv
    checkLinearity :: UsageEnv -> Var -> LintM UsageEnv
    checkLinearity UsageEnv
    body_ue Var
    lam_var =
      case Var -> Maybe LintedType
    varMultMaybe Var
    lam_var of
        Just LintedType
    mult -> do
          let (Usage
    lhs, UsageEnv
    body_ue') = UsageEnv -> Var -> (Usage, UsageEnv)
    forall n. NamedThing n => UsageEnv -> n -> (Usage, UsageEnv)
    popUE UsageEnv
    body_ue Var
    lam_var
              err_msg :: SDoc
    err_msg = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Linearity failure in lambda:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    lam_var
                        SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    lhs SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "⊈" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    mult
          Usage -> LintedType -> SDoc -> LintM ()
    ensureSubUsage Usage
    lhs LintedType
    mult SDoc
    err_msg
          UsageEnv -> LintM UsageEnv
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UsageEnv
    body_ue'
        Maybe LintedType
    Nothing    -> UsageEnv -> LintM UsageEnv
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UsageEnv
    body_ue -- A type variable

    {- Note [Join points and casts]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    You might think that this should be OK:
       join j x = rhs
       in (case e of
              A   -> alt1
              B x -> (jump j x) |> co)

    You might think that, since the cast is ultimately erased, the jump to
    `j` should still be OK as a join point.  But no!  See #21716. Suppose

      newtype Age = MkAge Int   -- axAge :: Age ~ Int
      f :: Int -> ...           -- f strict in it's first argument

    and consider the expression

      f (join j :: Bool -> Age
              j x = (rhs1 :: Age)
         in case v of
             Just x  -> (j x |> axAge :: Int)
             Nothing -> rhs2)

    Then, if the Simplifier pushes the strict call into the join points
    and alternatives we'll get

       join j' x = f (rhs1 :: Age)
       in case v of
          Just x  -> j' x |> axAge
          Nothing -> f rhs2

    Utterly bogus.  `f` expects an `Int` and we are giving it an `Age`.
    No no no.  Casts destroy the tail-call property.  Henc markAllJoinsBad
    in the (Cast expr co) case of lintCoreExpr.

    Note [No alternatives lint check]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Case expressions with no alternatives are odd beasts, and it would seem
    like they would worth be looking at in the linter (cf #10180). We
    used to check two things:

    * exprIsHNF is false: it would *seem* to be terribly wrong if
      the scrutinee was already in head normal form.

    * exprIsDeadEnd is true: we should be able to see why GHC believes the
      scrutinee is diverging for sure.

    It was already known that the second test was not entirely reliable.
    Unfortunately (#13990), the first test turned out not to be reliable
    either. Getting the checks right turns out to be somewhat complicated.

    For example, suppose we have (comment 8)

      data T a where
        TInt :: T Int

      absurdTBool :: T Bool -> a
      absurdTBool v = case v of

      data Foo = Foo !(T Bool)

      absurdFoo :: Foo -> a
      absurdFoo (Foo x) = absurdTBool x

    GHC initially accepts the empty case because of the GADT conditions. But then
    we inline absurdTBool, getting

      absurdFoo (Foo x) = case x of

    x is in normal form (because the Foo constructor is strict) but the
    case is empty. To avoid this problem, GHC would have to recognize
    that matching on Foo x is already absurd, which is not so easy.

    More generally, we don't really know all the ways that GHC can
    lose track of why an expression is bottom, so we shouldn't make too
    much fuss when that happens.

    Note [Beta redexes]
    ~~~~~~~~~~~~~~~~~~~
    Consider:

      join j @x y z = ... in
      (\@x y z -> jump j @x y z) @t e1 e2

    This is clearly ill-typed, since the jump is inside both an application and a
    lambda, either of which is enough to disqualify it as a tail call (see Note
    [Invariants on join points] in GHC.Core). However, strictly from a
    lambda-calculus perspective, the term doesn't go wrong---after the two beta
    reductions, the jump *is* a tail call and everything is fine.

    Why would we want to allow this when we have let? One reason is that a compound
    beta redex (that is, one with more than one argument) has different scoping
    rules: naively reducing the above example using lets will capture any free
    occurrence of y in e2. More fundamentally, type lets are tricky; many passes,
    such as Float Out, tacitly assume that the incoming program's type lets have
    all been dealt with by the simplifier. Thus we don't want to let-bind any types
    in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately
    before Float Out.

    All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this
    loophole, doing so to avoid re-traversing large functions (beta-reducing a type
    lambda without introducing a type let requires a substitution). TODO: Improve
    simpleOptPgm so that we can forget all this ever happened.

    ************************************************************************
    *                                                                      *
    \subsection[lintCoreArgs]{lintCoreArgs}
    *                                                                      *
    ************************************************************************

    The basic version of these functions checks that the argument is a
    subtype of the required type, as one would expect.
    -}

    -- Takes the functions type and arguments as argument.
    -- Returns the *result* of applying the function to arguments.
    -- e.g. f :: Int -> Bool -> Int would return `Int` as result type.
    lintCoreArgs  :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv)
    lintCoreArgs :: (LintedType, UsageEnv)
    -> [CoreExpr] -> LintM (LintedType, UsageEnv)
    lintCoreArgs (LintedType
    fun_ty, UsageEnv
    fun_ue) [CoreExpr]
    args = ((LintedType, UsageEnv)
     -> CoreExpr -> LintM (LintedType, UsageEnv))
    -> (LintedType, UsageEnv)
    -> [CoreExpr]
    -> LintM (LintedType, UsageEnv)
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (LintedType, UsageEnv) -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreArg (LintedType
    fun_ty, UsageEnv
    fun_ue) [CoreExpr]
    args

    lintCoreArg  :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv)

    -- Type argument
    lintCoreArg :: (LintedType, UsageEnv) -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreArg (LintedType
    fun_ty, UsageEnv
    ue) (Type LintedType
    arg_ty)
      = do { Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (LintedType -> Bool
    isCoercionTy LintedType
    arg_ty))
                    (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Unnecessary coercion-to-type injection:"
                      SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty)
           ; arg_ty' <- LintedType -> LintM LintedType
    lintType LintedType
    arg_ty
           ; res <- lintTyApp fun_ty arg_ty'
           ; return (res, ue) }

    -- Coercion argument
    lintCoreArg (LintedType
    fun_ty, UsageEnv
    ue) (Coercion Coercion
    co)
      = do { co' <- LintLocInfo -> LintM Coercion -> LintM Coercion
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Coercion -> LintLocInfo
    InCo Coercion
    co) (LintM Coercion -> LintM Coercion)
    -> LintM Coercion -> LintM Coercion
    forall a b. (a -> b) -> a -> b
    $
                    Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; res <- lintCoApp fun_ty co'
           ; return (res, ue) }

    -- Other value argument
    lintCoreArg (LintedType
    fun_ty, UsageEnv
    fun_ue) CoreExpr
    arg
      = do { (arg_ty, arg_ue) <- LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    arg
               -- See Note [Representation polymorphism invariants] in GHC.Core
           ; flags <- getLintFlags

           ; when (lf_check_fixed_rep flags) $
             -- Only check that 'arg_ty' has a fixed RuntimeRep
             -- if 'lf_check_fixed_rep' is on.
             do { checkL (typeHasFixedRuntimeRep arg_ty)
                         (text "Argument does not have a fixed runtime representation"
                          <+> ppr arg <+> dcolon
                          <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) }

           ; lintValApp arg fun_ty arg_ty fun_ue arg_ue }

    -----------------
    lintAltBinders :: UsageEnv
                   -> Var         -- Case binder
                   -> LintedType     -- Scrutinee type
                   -> LintedType     -- Constructor type
                   -> [(Mult, OutVar)]    -- Binders
                   -> LintM UsageEnv
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintAltBinders :: UsageEnv
    -> Var
    -> LintedType
    -> LintedType
    -> [(LintedType, Var)]
    -> LintM UsageEnv
    lintAltBinders UsageEnv
    rhs_ue Var
    _case_bndr LintedType
    scrut_ty LintedType
    con_ty []
      = do { LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    con_ty LintedType
    scrut_ty (LintedType -> LintedType -> SDoc
    mkBadPatMsg LintedType
    con_ty LintedType
    scrut_ty)
           ; UsageEnv -> LintM UsageEnv
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UsageEnv
    rhs_ue }
    lintAltBinders UsageEnv
    rhs_ue Var
    case_bndr LintedType
    scrut_ty LintedType
    con_ty ((LintedType
    var_w, Var
    bndr):[(LintedType, Var)]
    bndrs)
      | Var -> Bool
    isTyVar Var
    bndr
      = do { con_ty' <- LintedType -> LintedType -> LintM LintedType
    lintTyApp LintedType
    con_ty (Var -> LintedType
    mkTyVarTy Var
    bndr)
           ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty'  bndrs }
      | Bool
    otherwise
      = do { (con_ty', _) <- CoreExpr
    -> LintedType
    -> LintedType
    -> UsageEnv
    -> UsageEnv
    -> LintM (LintedType, UsageEnv)
    lintValApp (Var -> CoreExpr
    forall b. Var -> Expr b
    Var Var
    bndr) LintedType
    con_ty (Var -> LintedType
    idType Var
    bndr) UsageEnv
    zeroUE UsageEnv
    zeroUE
             -- We can pass zeroUE to lintValApp because we ignore its usage
             -- calculation and compute it in the call for checkCaseLinearity below.
           ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr
           ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }

    -- | Implements the case rules for linearity
    checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv
    checkCaseLinearity :: UsageEnv -> Var -> LintedType -> Var -> LintM UsageEnv
    checkCaseLinearity UsageEnv
    ue Var
    case_bndr LintedType
    var_w Var
    bndr = do
      Usage -> LintedType -> SDoc -> LintM ()
    ensureSubUsage Usage
    lhs LintedType
    rhs SDoc
    err_msg
      SDoc -> LintedType -> LintedType -> LintM ()
    lintLinearBinder (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr) (LintedType
    case_bndr_w LintedType -> LintedType -> LintedType
    `mkMultMul` LintedType
    var_w) (Var -> LintedType
    varMult Var
    bndr)
      UsageEnv -> LintM UsageEnv
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UsageEnv -> LintM UsageEnv) -> UsageEnv -> LintM UsageEnv
    forall a b. (a -> b) -> a -> b
    $ UsageEnv -> Var -> UsageEnv
    forall n. NamedThing n => UsageEnv -> n -> UsageEnv
    deleteUE UsageEnv
    ue Var
    bndr
      where
        lhs :: Usage
    lhs = Usage
    bndr_usage Usage -> Usage -> Usage
    `addUsage` (LintedType
    var_w LintedType -> Usage -> Usage
    `scaleUsage` Usage
    case_bndr_usage)
        rhs :: LintedType
    rhs = LintedType
    case_bndr_w LintedType -> LintedType -> LintedType
    `mkMultMul` LintedType
    var_w
        err_msg :: SDoc
    err_msg  = (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Linearity failure in variable:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr
                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    lhs SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "⊈" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs
                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Computed by:"
                    SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "LHS:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    lhs_formula
                    SDoc -> SDoc -> SDoc
    forall doc. IsLine 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
    <+> SDoc
    rhs_formula)
        lhs_formula :: SDoc
    lhs_formula = Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    bndr_usage SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "+"
                                     SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    case_bndr_usage SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "*" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    var_w)
        rhs_formula :: SDoc
    rhs_formula = LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    case_bndr_w SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "*" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    var_w
        case_bndr_w :: LintedType
    case_bndr_w = Var -> LintedType
    varMult Var
    case_bndr
        case_bndr_usage :: Usage
    case_bndr_usage = UsageEnv -> Var -> Usage
    forall n. NamedThing n => UsageEnv -> n -> Usage
    lookupUE UsageEnv
    ue Var
    case_bndr
        bndr_usage :: Usage
    bndr_usage = UsageEnv -> Var -> Usage
    forall n. NamedThing n => UsageEnv -> n -> Usage
    lookupUE UsageEnv
    ue Var
    bndr

    -----------------
    lintTyApp :: LintedType -> LintedType -> LintM LintedType
    lintTyApp :: LintedType -> LintedType -> LintM LintedType
    lintTyApp LintedType
    fun_ty LintedType
    arg_ty
      | Just (Var
    tv,LintedType
    body_ty) <- LintedType -> Maybe (Var, LintedType)
    splitForAllTyVar_maybe LintedType
    fun_ty
      = do  { Var -> LintedType -> LintM ()
    lintTyKind Var
    tv LintedType
    arg_ty
            ; in_scope <- LintM InScopeSet
    getInScope
            -- substTy needs the set of tyvars in scope to avoid generating
            -- uniques that are already in scope.
            -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst
            ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }

      | Bool
    otherwise
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (LintedType -> LintedType -> SDoc
    mkTyAppMsg LintedType
    fun_ty LintedType
    arg_ty)

    -----------------
    lintCoApp :: LintedType -> LintedCoercion -> LintM LintedType
    lintCoApp :: LintedType -> Coercion -> LintM LintedType
    lintCoApp LintedType
    fun_ty Coercion
    co
      | Just (Var
    cv,LintedType
    body_ty) <- LintedType -> Maybe (Var, LintedType)
    splitForAllCoVar_maybe LintedType
    fun_ty
      , let co_ty :: LintedType
    co_ty = Coercion -> LintedType
    coercionType Coercion
    co
            cv_ty :: LintedType
    cv_ty = Var -> LintedType
    idType Var
    cv
      , LintedType
    cv_ty HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    co_ty
      = do { in_scope <- LintM InScopeSet
    getInScope
           ; let init_subst = InScopeSet -> Subst
    mkEmptySubst InScopeSet
    in_scope
                 subst = Subst -> Var -> Coercion -> Subst
    extendCvSubst Subst
    init_subst Var
    cv Coercion
    co
           ; return (substTy subst body_ty) }

      | Just (FunTyFlag
    _, LintedType
    _, LintedType
    arg_ty', LintedType
    res_ty') <- LintedType -> Maybe (FunTyFlag, LintedType, LintedType, LintedType)
    splitFunTy_maybe LintedType
    fun_ty
      , LintedType
    co_ty HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    arg_ty'
      = LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    res_ty')

      | Bool
    otherwise
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (LintedType -> Coercion -> SDoc
    mkCoAppMsg LintedType
    fun_ty Coercion
    co)

      where
        co_ty :: LintedType
    co_ty = Coercion -> LintedType
    coercionType Coercion
    co

    -----------------

    -- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@
    -- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the
    -- application.
    lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv
               -> LintM (LintedType, UsageEnv)
    lintValApp :: CoreExpr
    -> LintedType
    -> LintedType
    -> UsageEnv
    -> UsageEnv
    -> LintM (LintedType, UsageEnv)
    lintValApp CoreExpr
    arg LintedType
    fun_ty LintedType
    arg_ty UsageEnv
    fun_ue UsageEnv
    arg_ue
      | Just (FunTyFlag
    _, LintedType
    w, LintedType
    arg_ty', LintedType
    res_ty') <- LintedType -> Maybe (FunTyFlag, LintedType, LintedType, LintedType)
    splitFunTy_maybe LintedType
    fun_ty
      = do { LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    arg_ty' LintedType
    arg_ty (LintedType -> LintedType -> CoreExpr -> SDoc
    mkAppMsg LintedType
    arg_ty' LintedType
    arg_ty CoreExpr
    arg)
           ; let app_ue :: UsageEnv
    app_ue =  UsageEnv -> UsageEnv -> UsageEnv
    addUE UsageEnv
    fun_ue (LintedType -> UsageEnv -> UsageEnv
    scaleUE LintedType
    w UsageEnv
    arg_ue)
           ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    res_ty', UsageEnv
    app_ue) }
      | Bool
    otherwise
      = SDoc -> LintM (LintedType, UsageEnv)
    forall a. SDoc -> LintM a
    failWithL SDoc
    err2
      where
        err2 :: SDoc
    err2 = LintedType -> LintedType -> CoreExpr -> SDoc
    mkNonFunAppMsg LintedType
    fun_ty LintedType
    arg_ty CoreExpr
    arg

    lintTyKind :: OutTyVar -> LintedType -> LintM ()
    -- Both args have had substitution applied

    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintTyKind :: Var -> LintedType -> LintM ()
    lintTyKind Var
    tyvar LintedType
    arg_ty
      = Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    arg_kind HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    tyvar_kind) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        SDoc -> LintM ()
    addErrL (Var -> LintedType -> SDoc
    mkKindErrMsg Var
    tyvar LintedType
    arg_ty SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Linted Arg kind:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_kind))
      where
        tyvar_kind :: LintedType
    tyvar_kind = Var -> LintedType
    tyVarKind Var
    tyvar
        arg_kind :: LintedType
    arg_kind = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    arg_ty

    {-
    ************************************************************************
    *                                                                      *
    \subsection[lintCoreAlts]{lintCoreAlts}
    *                                                                      *
    ************************************************************************
    -}

    lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv)
    lintCaseExpr :: CoreExpr
    -> Var -> LintedType -> [Alt Var] -> LintM (LintedType, UsageEnv)
    lintCaseExpr CoreExpr
    scrut Var
    var LintedType
    alt_ty [Alt Var]
    alts =
      do { let e :: CoreExpr
    e = CoreExpr -> Var -> LintedType -> [Alt Var] -> CoreExpr
    forall b. Expr b -> b -> LintedType -> [Alt b] -> Expr b
    Case CoreExpr
    scrut Var
    var LintedType
    alt_ty [Alt Var]
    alts   -- Just for error messages

         -- Check the scrutinee
         ; (scrut_ty, scrut_ue) <- LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    scrut
              -- See Note [Join points are less general than the paper]
              -- in GHC.Core
         ; let scrut_mult = Var -> LintedType
    varMult Var
    var

         ; alt_ty <- addLoc (CaseTy scrut) $
                     lintValueType alt_ty
         ; var_ty <- addLoc (IdTy var) $
                     lintValueType (idType var)

         -- We used to try to check whether a case expression with no
         -- alternatives was legitimate, but this didn't work.
         -- See Note [No alternatives lint check] for details.

         -- Check that the scrutinee is not a floating-point type
         -- if there are any literal alternatives
         -- See GHC.Core Note [Case expression invariants] item (5)
         -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold
         ; let isLitPat (Alt (LitAlt Literal
    _) [b]
    _  Expr b
    _) = Bool
    True
               isLitPat Alt b
    _                     = Bool
    False
         ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts)
             (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."
              $$ text "scrut" <+> ppr scrut)

         ; case tyConAppTyCon_maybe (idType var) of
             Just TyCon
    tycon
                  | Bool
    debugIsOn
                  , TyCon -> Bool
    isAlgTyCon TyCon
    tycon
                  , Bool -> Bool
    not (TyCon -> Bool
    isAbstractTyCon TyCon
    tycon)
                  , [DataCon] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (TyCon -> [DataCon]
    tyConDataCons TyCon
    tycon)
                  , Bool -> Bool
    not (CoreExpr -> Bool
    exprIsDeadEnd CoreExpr
    scrut)
                  -> String -> SDoc -> LintM () -> LintM ()
    forall a. String -> SDoc -> a -> a
    pprTrace String
    "Lint warning: case binder's type has no constructors" (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    var))
                            -- This can legitimately happen for type families
                          (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
             Maybe TyCon
    _otherwise -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

            -- Don't use lintIdBndr on var, because unboxed tuple is legitimate

         ; subst <- getSubst
         ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
           -- See GHC.Core Note [Case expression invariants] item (7)

         ; lintBinder CaseBind var $ \Var
    _ ->
           do { -- Check the alternatives
              ; alt_ues <- (Alt Var -> LintM UsageEnv) -> [Alt Var] -> LintM [UsageEnv]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Var
    -> LintedType
    -> LintedType
    -> LintedType
    -> Alt Var
    -> LintM UsageEnv
    lintCoreAlt Var
    var LintedType
    scrut_ty LintedType
    scrut_mult LintedType
    alt_ty) [Alt Var]
    alts
              ; let case_ue = (LintedType -> UsageEnv -> UsageEnv
    scaleUE LintedType
    scrut_mult UsageEnv
    scrut_ue) UsageEnv -> UsageEnv -> UsageEnv
    `addUE` [UsageEnv] -> UsageEnv
    supUEs [UsageEnv]
    alt_ues
              ; checkCaseAlts e scrut_ty alts
              ; return (alt_ty, case_ue) } }

    checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM ()
    -- a) Check that the alts are non-empty
    -- b1) Check that the DEFAULT comes first, if it exists
    -- b2) Check that the others are in increasing order
    -- c) Check that there's a default for infinite types
    -- NB: Algebraic cases are not necessarily exhaustive, because
    --     the simplifier correctly eliminates case that can't
    --     possibly match.

    checkCaseAlts :: CoreExpr -> LintedType -> [Alt Var] -> LintM ()
    checkCaseAlts CoreExpr
    e LintedType
    ty [Alt Var]
    alts =
      do { Bool -> SDoc -> LintM ()
    checkL ((Alt Var -> Bool) -> [Alt Var] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Alt Var -> Bool
    forall {b}. Alt b -> Bool
    non_deflt [Alt Var]
    con_alts) (CoreExpr -> SDoc
    mkNonDefltMsg CoreExpr
    e)
             -- See GHC.Core Note [Case expression invariants] item (2)

         ; Bool -> SDoc -> LintM ()
    checkL ([Alt Var] -> Bool
    forall {a}. [Alt a] -> Bool
    increasing_tag [Alt Var]
    con_alts) (CoreExpr -> SDoc
    mkNonIncreasingAltsMsg CoreExpr
    e)
             -- See GHC.Core Note [Case expression invariants] item (3)

              -- For types Int#, Word# with an infinite (well, large!) number of
              -- possible values, there should usually be a DEFAULT case
              -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to
              -- have *no* case alternatives.
              -- In effect, this is a kind of partial test. I suppose it's possible
              -- that we might *know* that 'x' was 1 or 2, in which case
              --   case x of { 1 -> e1; 2 -> e2 }
              -- would be fine.
         ; Bool -> SDoc -> LintM ()
    checkL (Maybe CoreExpr -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe CoreExpr
    maybe_deflt Bool -> Bool -> Bool
    || Bool -> Bool
    not Bool
    is_infinite_ty Bool -> Bool -> Bool
    || [Alt Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Alt Var]
    alts)
                  (CoreExpr -> SDoc
    nonExhaustiveAltsMsg CoreExpr
    e) }
      where
        ([Alt Var]
    con_alts, Maybe CoreExpr
    maybe_deflt) = [Alt Var] -> ([Alt Var], Maybe CoreExpr)
    forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
    findDefault [Alt Var]
    alts

            -- Check that successive alternatives have strictly increasing tags
        increasing_tag :: [Alt a] -> Bool
    increasing_tag (Alt a
    alt1 : rest :: [Alt a]
    rest@( Alt a
    alt2 : [Alt a]
    _)) = Alt a
    alt1 Alt a -> Alt a -> Bool
    forall a. Alt a -> Alt a -> Bool
    `ltAlt` Alt a
    alt2 Bool -> Bool -> Bool
    && [Alt a] -> Bool
    increasing_tag [Alt a]
    rest
        increasing_tag [Alt a]
    _                         = Bool
    True

        non_deflt :: Alt b -> Bool
    non_deflt (Alt AltCon
    DEFAULT [b]
    _ Expr b
    _) = Bool
    False
        non_deflt Alt b
    _                 = Bool
    True

        is_infinite_ty :: Bool
    is_infinite_ty = case LintedType -> Maybe TyCon
    tyConAppTyCon_maybe LintedType
    ty of
                            Maybe TyCon
    Nothing    -> Bool
    False
                            Just TyCon
    tycon -> TyCon -> Bool
    isPrimTyCon TyCon
    tycon

    lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    expr LintedType
    ann_ty
      = do { (actual_ty, ue) <- CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr
           ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty)
           ; return ue }
             -- See GHC.Core Note [Case expression invariants] item (6)

    lintCoreAlt :: Var              -- Case binder
                -> LintedType       -- Type of scrutinee
                -> Mult             -- Multiplicity of scrutinee
                -> LintedType       -- Type of the alternative
                -> CoreAlt
                -> LintM UsageEnv
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintCoreAlt :: Var
    -> LintedType
    -> LintedType
    -> LintedType
    -> Alt Var
    -> LintM UsageEnv
    lintCoreAlt Var
    case_bndr LintedType
    _ LintedType
    scrut_mult LintedType
    alt_ty (Alt AltCon
    DEFAULT [Var]
    args CoreExpr
    rhs) =
      do { Bool -> SDoc -> LintM ()
    lintL ([Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    args) ([Var] -> SDoc
    mkDefaultArgsMsg [Var]
    args)
         ; rhs_ue <- CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    rhs LintedType
    alt_ty
         ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr
               err_msg = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Linearity failure in the DEFAULT clause:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    case_bndr
                         SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    case_bndr_usage SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "⊈" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_mult
         ; ensureSubUsage case_bndr_usage scrut_mult err_msg
         ; return rhs_ue' }

    lintCoreAlt Var
    case_bndr LintedType
    scrut_ty LintedType
    _ LintedType
    alt_ty (Alt (LitAlt Literal
    lit) [Var]
    args CoreExpr
    rhs)
      | Literal -> Bool
    litIsLifted Literal
    lit
      = SDoc -> LintM UsageEnv
    forall a. SDoc -> LintM a
    failWithL SDoc
    integerScrutinisedMsg
      | Bool
    otherwise
      = do { Bool -> SDoc -> LintM ()
    lintL ([Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    args) ([Var] -> SDoc
    mkDefaultArgsMsg [Var]
    args)
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    lit_ty LintedType
    scrut_ty (LintedType -> LintedType -> SDoc
    mkBadPatMsg LintedType
    lit_ty LintedType
    scrut_ty)
           ; rhs_ue <- CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    rhs LintedType
    alt_ty
           ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks
           }
      where
        lit_ty :: LintedType
    lit_ty = Literal -> LintedType
    literalType Literal
    lit

    lintCoreAlt Var
    case_bndr LintedType
    scrut_ty LintedType
    _scrut_mult LintedType
    alt_ty alt :: Alt Var
    alt@(Alt (DataAlt DataCon
    con) [Var]
    args CoreExpr
    rhs)
      | TyCon -> Bool
    isNewTyCon (DataCon -> TyCon
    dataConTyCon DataCon
    con)
      = UsageEnv
    zeroUE UsageEnv -> LintM () -> LintM UsageEnv
    forall a b. a -> LintM b -> LintM a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ SDoc -> LintM ()
    addErrL (LintedType -> Alt Var -> SDoc
    mkNewTyDataConAltMsg LintedType
    scrut_ty Alt Var
    alt)
      | Just (TyCon
    tycon, [LintedType]
    tycon_arg_tys) <- HasDebugCallStack => LintedType -> Maybe (TyCon, [LintedType])
    LintedType -> Maybe (TyCon, [LintedType])
    splitTyConApp_maybe LintedType
    scrut_ty
      = LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Alt Var -> LintLocInfo
    CaseAlt Alt Var
    alt) (LintM UsageEnv -> LintM UsageEnv)
    -> LintM UsageEnv -> LintM UsageEnv
    forall a b. (a -> b) -> a -> b
    $  do
        { String -> DataCon -> LintM ()
    checkTypeDataConOcc String
    "pattern" DataCon
    con
        ; Bool -> SDoc -> LintM ()
    lintL (TyCon
    tycon TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon -> TyCon
    dataConTyCon DataCon
    con) (TyCon -> DataCon -> SDoc
    mkBadConMsg TyCon
    tycon DataCon
    con)

          -- Instantiate the universally quantified
          -- type variables of the data constructor
        ; let { con_payload_ty :: LintedType
    con_payload_ty = HasDebugCallStack => LintedType -> [LintedType] -> LintedType
    LintedType -> [LintedType] -> LintedType
    piResultTys (DataCon -> LintedType
    dataConRepType DataCon
    con) [LintedType]
    tycon_arg_tys
              ; binderMult :: PiTyBinder -> LintedType
    binderMult (Named ForAllTyBinder
    _)   = LintedType
    ManyTy
              ; binderMult (Anon Scaled LintedType
    st FunTyFlag
    _) = Scaled LintedType -> LintedType
    forall a. Scaled a -> LintedType
    scaledMult Scaled LintedType
    st
              -- See Note [Validating multiplicities in a case]
              ; multiplicities :: [LintedType]
    multiplicities = (PiTyBinder -> LintedType) -> [PiTyBinder] -> [LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map PiTyBinder -> LintedType
    binderMult ([PiTyBinder] -> [LintedType]) -> [PiTyBinder] -> [LintedType]
    forall a b. (a -> b) -> a -> b
    $ ([PiTyBinder], LintedType) -> [PiTyBinder]
    forall a b. (a, b) -> a
    fst (([PiTyBinder], LintedType) -> [PiTyBinder])
    -> ([PiTyBinder], LintedType) -> [PiTyBinder]
    forall a b. (a -> b) -> a -> b
    $ LintedType -> ([PiTyBinder], LintedType)
    splitPiTys LintedType
    con_payload_ty }

            -- And now bring the new binders into scope
        ; BindingSite -> [Var] -> ([Var] -> LintM UsageEnv) -> LintM UsageEnv
    forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintBinders BindingSite
    CasePatBind [Var]
    args (([Var] -> LintM UsageEnv) -> LintM UsageEnv)
    -> ([Var] -> LintM UsageEnv) -> LintM UsageEnv
    forall a b. (a -> b) -> a -> b
    $ \ [Var]
    args' -> do
          {
            rhs_ue <- CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    rhs LintedType
    alt_ty
          ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities  args'))
          ; return $ deleteUE rhs_ue' case_bndr
          }
       }

      | Bool
    otherwise   -- Scrut-ty is wrong shape
      = UsageEnv
    zeroUE UsageEnv -> LintM () -> LintM UsageEnv
    forall a b. a -> LintM b -> LintM a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ SDoc -> LintM ()
    addErrL (LintedType -> Alt Var -> SDoc
    mkBadAltMsg LintedType
    scrut_ty Alt Var
    alt)

    {-
    Note [Validating multiplicities in a case]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose 'MkT :: a %m -> T m a'.
    If we are validating 'case (x :: T Many a) of MkT y -> ...',
    we have to substitute m := Many in the type of MkT - in particular,
    y can be used Many times and that expression would still be linear in x.
    We do this by looking at con_payload_ty, which is the type of the datacon
    applied to the surrounding arguments.
    Testcase: linear/should_compile/MultConstructor

    Data constructors containing existential tyvars will then have
    Named binders, which are always multiplicity Many.
    Testcase: indexed-types/should_compile/GADT1
    -}

    lintLinearBinder :: SDoc -> Mult -> Mult -> LintM ()
    lintLinearBinder :: SDoc -> LintedType -> LintedType -> LintM ()
    lintLinearBinder SDoc
    doc LintedType
    actual_usage LintedType
    described_usage
      = LintedType -> LintedType -> SDoc -> LintM ()
    ensureSubMult LintedType
    actual_usage LintedType
    described_usage SDoc
    err_msg
        where
          err_msg :: SDoc
    err_msg = (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Multiplicity of variable does not agree with its context"
                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    doc
                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    actual_usage
                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Annotation:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    described_usage)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[lint-types]{Types}
    *                                                                      *
    ************************************************************************
    -}

    -- When we lint binders, we (one at a time and in order):
    --  1. Lint var types or kinds (possibly substituting)
    --  2. Add the binder to the in scope set, and if its a coercion var,
    --     we may extend the substitution to reflect its (possibly) new kind
    lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintBinders :: forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintBinders BindingSite
    _    []         [Var] -> LintM a
    linterF = [Var] -> LintM a
    linterF []
    lintBinders BindingSite
    site (Var
    var:[Var]
    vars) [Var] -> LintM a
    linterF = BindingSite -> Var -> (Var -> LintM a) -> LintM a
    forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintBinder BindingSite
    site Var
    var ((Var -> LintM a) -> LintM a) -> (Var -> LintM a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Var
    var' ->
                                          BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintBinders BindingSite
    site [Var]
    vars (([Var] -> LintM a) -> LintM a) -> ([Var] -> LintM a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ [Var]
    vars' ->
                                          [Var] -> LintM a
    linterF (Var
    var'Var -> [Var] -> [Var]
    forall a. a -> [a] -> [a]
    :[Var]
    vars')

    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintBinder :: forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintBinder BindingSite
    site Var
    var Var -> LintM a
    linterF
      | Var -> Bool
    isTyCoVar Var
    var = Var -> (Var -> LintM a) -> LintM a
    forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyCoBndr Var
    var Var -> LintM a
    linterF
      | Bool
    otherwise     = TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
    forall a.
    TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintIdBndr TopLevelFlag
    NotTopLevel BindingSite
    site Var
    var Var -> LintM a
    linterF

    lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a
    lintTyBndr :: forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyBndr = Var -> (Var -> LintM a) -> LintM a
    forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyCoBndr  -- We could specialise it, I guess

    lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a
    lintTyCoBndr :: forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyCoBndr Var
    tcv Var -> LintM a
    thing_inside
      = do { subst <- LintM Subst
    getSubst
           ; tcv_type' <- lintType (varType tcv)
           ; let tcv' = InScopeSet -> Var -> Var
    uniqAway (Subst -> InScopeSet
    getSubstInScope Subst
    subst) (Var -> Var) -> Var -> Var
    forall a b. (a -> b) -> a -> b
    $
                        Var -> LintedType -> Var
    setVarType Var
    tcv LintedType
    tcv_type'
                 subst' = Subst -> Var -> Var -> Subst
    extendTCvSubstWithClone Subst
    subst Var
    tcv Var
    tcv'

           -- See (FORALL1) and (FORALL2) in GHC.Core.Type
           ; if (isTyVar tcv)
             then -- Check that in (forall (a:ki). blah) we have ki:Type
                  lintL (isLiftedTypeKind (typeKind tcv_type')) $
                  hang (text "TyVar whose kind does not have kind Type:")
                     2 (ppr tcv' <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr (typeKind tcv_type'))
             else -- Check that in (forall (cv::ty). blah),
                  -- then ty looks like (t1 ~# t2)
                  lintL (isCoVarType tcv_type') $
                  text "CoVar with non-coercion type:" <+> pprTyVar tcv

           ; updateSubst subst' (thing_inside tcv') }

    lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a
    lintIdBndrs :: forall a. TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintIdBndrs TopLevelFlag
    top_lvl [Var]
    ids [Var] -> LintM a
    thing_inside
      = [Var] -> ([Var] -> LintM a) -> LintM a
    go [Var]
    ids [Var] -> LintM a
    thing_inside
      where
        go :: [Id] -> ([Id] -> LintM a) -> LintM a
        go :: [Var] -> ([Var] -> LintM a) -> LintM a
    go []       [Var] -> LintM a
    thing_inside = [Var] -> LintM a
    thing_inside []
        go (Var
    id:[Var]
    ids) [Var] -> LintM a
    thing_inside = TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
    forall a.
    TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintIdBndr TopLevelFlag
    top_lvl BindingSite
    LetBind Var
    id  ((Var -> LintM a) -> LintM a) -> (Var -> LintM a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \Var
    id' ->
                                   [Var] -> ([Var] -> LintM a) -> LintM a
    go [Var]
    ids                         (([Var] -> LintM a) -> LintM a) -> ([Var] -> LintM a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \[Var]
    ids' ->
                                   [Var] -> LintM a
    thing_inside (Var
    id' Var -> [Var] -> [Var]
    forall a. a -> [a] -> [a]
    : [Var]
    ids')

    lintIdBndr :: TopLevelFlag -> BindingSite
               -> InVar -> (OutVar -> LintM a) -> LintM a
    -- Do substitution on the type of a binder and add the var with this
    -- new type to the in-scope set of the second argument
    -- ToDo: lint its rules
    lintIdBndr :: forall a.
    TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintIdBndr TopLevelFlag
    top_lvl BindingSite
    bind_site Var
    id Var -> LintM a
    thing_inside
      = Bool -> SDoc -> LintM a -> LintM a
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Var -> Bool
    isId Var
    id) (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    id) (LintM a -> LintM a) -> LintM a -> LintM a
    forall a b. (a -> b) -> a -> b
    $
        do { flags <- LintM LintFlags
    getLintFlags
           ; checkL (not (lf_check_global_ids flags) || isLocalId id)
                    (text "Non-local Id binder" <+> ppr id)
                    -- See Note [Checking for global Ids]

           -- Check that if the binder is nested, it is not marked as exported
           ; checkL (not (isExportedId id) || is_top_lvl)
               (mkNonTopExportedMsg id)

           -- Check that if the binder is nested, it does not have an external name
           ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)
               (mkNonTopExternalNameMsg id)

              -- See Note [Representation polymorphism invariants] in GHC.Core
           ; lintL (isJoinId id || not (lf_check_fixed_rep flags)
                    || typeHasFixedRuntimeRep id_ty) $
             text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+>
                parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty))

           -- Check that a join-id is a not-top-level let-binding
           ; when (isJoinId id) $
             checkL (not is_top_lvl && is_let_bind) $
             mkBadJoinBindMsg id

           -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);
           -- if so, it should be a CoVar, and checked by lintCoVarBndr
           ; lintL (not (isCoVarType id_ty))
                   (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)

           -- Check that the lambda binder has no value or OtherCon unfolding.
           -- See #21496
           ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))
                    (text "Lambda binder with value or OtherCon unfolding.")

           ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty)

           ; addInScopeId id linted_ty $
             thing_inside (setIdType id linted_ty) }
      where
        id_ty :: LintedType
    id_ty = Var -> LintedType
    idType Var
    id

        is_top_lvl :: Bool
    is_top_lvl = TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl
        is_let_bind :: Bool
    is_let_bind = case BindingSite
    bind_site of
                        BindingSite
    LetBind -> Bool
    True
                        BindingSite
    _       -> Bool
    False

    {-
    %************************************************************************
    %*                                                                      *
                 Types
    %*                                                                      *
    %************************************************************************
    -}

    lintValueType :: Type -> LintM LintedType
    -- Types only, not kinds
    -- Check the type, and apply the substitution to it
    -- See Note [Linting type lets]
    lintValueType :: LintedType -> LintM LintedType
    lintValueType LintedType
    ty
      = LintLocInfo -> LintM LintedType -> LintM LintedType
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (LintedType -> LintLocInfo
    InType LintedType
    ty) (LintM LintedType -> LintM LintedType)
    -> LintM LintedType -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $
        do  { ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
            ; let sk = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty'
            ; lintL (isTYPEorCONSTRAINT sk) $
              hang (text "Ill-kinded type:" <+> ppr ty)
                 2 (text "has kind:" <+> ppr sk)
            ; return ty' }

    checkTyCon :: TyCon -> LintM ()
    checkTyCon :: TyCon -> LintM ()
    checkTyCon TyCon
    tc
      = Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (TyCon -> Bool
    isTcTyCon TyCon
    tc)) (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Found TcTyCon:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc)

    -------------------
    checkTyCoVarInScope :: Subst -> TyCoVar -> LintM ()
    checkTyCoVarInScope :: Subst -> Var -> LintM ()
    checkTyCoVarInScope Subst
    subst Var
    tcv
      = Bool -> SDoc -> LintM ()
    checkL (Var
    tcv Var -> Subst -> Bool
    `isInScope` Subst
    subst) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "The type or coercion variable" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    tcv)
           JoinArity
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "is out of scope")

    -------------------
    lintType :: Type -> LintM LintedType

    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintType :: LintedType -> LintM LintedType
    lintType (TyVarTy Var
    tv)
      | Bool -> Bool
    not (Var -> Bool
    isTyVar Var
    tv)
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (Var -> SDoc
    mkBadTyVarMsg Var
    tv)

      | Bool
    otherwise
      = do { subst <- LintM Subst
    getSubst
           ; case lookupTyVar subst tv of
               Just LintedType
    linted_ty -> LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LintedType
    linted_ty

               -- In GHCi we may lint an expression with a free
               -- type variable.  Then it won't be in the
               -- substitution, but it should be in scope
               Maybe LintedType
    Nothing -> do { Subst -> Var -> LintM ()
    checkTyCoVarInScope Subst
    subst Var
    tv
                             ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> LintedType
    TyVarTy Var
    tv) }
         }

    lintType ty :: LintedType
    ty@(AppTy LintedType
    t1 LintedType
    t2)
      | TyConApp {} <- LintedType
    t1
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM LintedType) -> SDoc -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "TyConApp to the left of AppTy:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty
      | Bool
    otherwise
      = do { t1' <- LintedType -> LintM LintedType
    lintType LintedType
    t1
           ; t2' <- lintType t2
           ; lint_ty_app ty (typeKind t1') [t2']
           ; return (AppTy t1' t2') }

    lintType ty :: LintedType
    ty@(TyConApp TyCon
    tc [LintedType]
    tys)
      | TyCon -> Bool
    isTypeSynonymTyCon TyCon
    tc Bool -> Bool -> Bool
    || TyCon -> Bool
    isTypeFamilyTyCon TyCon
    tc
      = do { report_unsat <- LintFlags -> Bool
    lf_report_unsat_syns (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LintM LintFlags
    getLintFlags
           ; lintTySynFamApp report_unsat ty tc tys }

      | Just {} <- HasDebugCallStack => TyCon -> [LintedType] -> Maybe LintedType
    TyCon -> [LintedType] -> Maybe LintedType
    tyConAppFunTy_maybe TyCon
    tc [LintedType]
    tys
        -- We should never see a saturated application of funTyCon; such
        -- applications should be represented with the FunTy constructor.
        -- See Note [Linting function types]
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Saturated application of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc)) JoinArity
    2 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty))

      | Bool
    otherwise  -- Data types, data families, primitive types
      = do { TyCon -> LintM ()
    checkTyCon TyCon
    tc
           ; tys' <- (LintedType -> LintM LintedType)
    -> [LintedType] -> LintM [LintedType]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM LintedType -> LintM LintedType
    lintType [LintedType]
    tys
           ; lint_ty_app ty (tyConKind tc) tys'
           ; return (TyConApp tc tys') }

    -- arrows can related *unlifted* kinds, so this has to be separate from
    -- a dependent forall.
    lintType ty :: LintedType
    ty@(FunTy FunTyFlag
    af LintedType
    tw LintedType
    t1 LintedType
    t2)
      = do { t1' <- LintedType -> LintM LintedType
    lintType LintedType
    t1
           ; t2' <- lintType t2
           ; tw' <- lintType tw
           ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw'
           ; let real_af = HasDebugCallStack => LintedType -> LintedType -> FunTyFlag
    LintedType -> LintedType -> FunTyFlag
    chooseFunTyFlag LintedType
    t1 LintedType
    t2
           ; unless (real_af == af) $ addErrL $
             hang (text "Bad FunTyFlag in FunTy")
                2 (vcat [ ppr ty
                        , text "FunTyFlag =" <+> ppr af
                        , text "Computed FunTyFlag =" <+> ppr real_af ])
           ; return (FunTy af tw' t1' t2') }

    lintType ty :: LintedType
    ty@(ForAllTy (Bndr Var
    tcv ForAllTyFlag
    vis) LintedType
    body_ty)
      | Bool -> Bool
    not (Var -> Bool
    isTyCoVar Var
    tcv)
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-Tyvar or Non-Covar bound in type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)
      | Bool
    otherwise
      = Var -> (Var -> LintM LintedType) -> LintM LintedType
    forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyCoBndr Var
    tcv ((Var -> LintM LintedType) -> LintM LintedType)
    -> (Var -> LintM LintedType) -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $ \Var
    tcv' ->
        do { body_ty' <- LintedType -> LintM LintedType
    lintType LintedType
    body_ty
           ; lintForAllBody tcv' body_ty'

           ; when (isCoVar tcv) $
             lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $
             text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)
             -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]

           ; return (ForAllTy (Bndr tcv' vis) body_ty') }

    lintType ty :: LintedType
    ty@(LitTy TyLit
    l)
      = do { TyLit -> LintM ()
    lintTyLit TyLit
    l; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LintedType
    ty }

    lintType (CastTy LintedType
    ty Coercion
    co)
      = do { ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; co' <- lintStarCoercion co
           ; let tyk = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty'
                 cok = HasDebugCallStack => Coercion -> LintedType
    Coercion -> LintedType
    coercionLKind Coercion
    co'
           ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok)
           ; return (CastTy ty' co') }

    lintType (CoercionTy Coercion
    co)
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; return (CoercionTy co') }

    -----------------
    lintForAllBody :: LintedTyCoVar -> LintedType -> LintM ()
    -- Do the checks for the body of a forall-type
    lintForAllBody :: Var -> LintedType -> LintM ()
    lintForAllBody Var
    tcv LintedType
    body_ty
      = do { LintedType -> SDoc -> LintM ()
    checkValueType LintedType
    body_ty (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "the body of forall:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    body_ty)

             -- For type variables, check for skolem escape
             -- See Note [Phantom type variables in kinds] in GHC.Core.Type
             -- The kind of (forall cv. th) is liftedTypeKind, so no
             -- need to check for skolem-escape in the CoVar case
           ; let body_kind :: LintedType
    body_kind = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    body_ty
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Var -> Bool
    isTyVar Var
    tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             case [Var] -> LintedType -> Maybe LintedType
    occCheckExpand [Var
    tcv] LintedType
    body_kind of
               Just {} -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
               Maybe LintedType
    Nothing -> SDoc -> LintM ()
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                          SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Variable escape in forall:")
                             JoinArity
    2 ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "tyvar:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tcv
                                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    body_ty
                                     , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "kind:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    body_kind ])
        }

    -----------------
    lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType
    -- The TyCon is a type synonym or a type family (not a data family)
    -- See Note [Linting type synonym applications]
    -- c.f. GHC.Tc.Validity.check_syn_tc_app
    lintTySynFamApp :: Bool -> LintedType -> TyCon -> [LintedType] -> LintM LintedType
    lintTySynFamApp Bool
    report_unsat LintedType
    ty TyCon
    tc [LintedType]
    tys
      | Bool
    report_unsat   -- Report unsaturated only if report_unsat is on
      , [LintedType]
    tys [LintedType] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthLessThan` TyCon -> JoinArity
    tyConArity TyCon
    tc
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Un-saturated type application") JoinArity
    2 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty))

      -- Deal with type synonyms
      | ExpandsSyn [(Var, LintedType)]
    tenv LintedType
    rhs [LintedType]
    tys' <- TyCon -> [LintedType] -> ExpandSynResult LintedType
    forall tyco. TyCon -> [tyco] -> ExpandSynResult tyco
    expandSynTyCon_maybe TyCon
    tc [LintedType]
    tys
      , let expanded_ty :: LintedType
    expanded_ty = LintedType -> [LintedType] -> LintedType
    mkAppTys (HasDebugCallStack => Subst -> LintedType -> LintedType
    Subst -> LintedType -> LintedType
    substTy ([(Var, LintedType)] -> Subst
    mkTvSubstPrs [(Var, LintedType)]
    tenv) LintedType
    rhs) [LintedType]
    tys'
      = do { -- Kind-check the argument types, but without reporting
             -- un-saturated type families/synonyms
             tys' <- Bool -> LintM [LintedType] -> LintM [LintedType]
    forall a. Bool -> LintM a -> LintM a
    setReportUnsat Bool
    False ((LintedType -> LintM LintedType)
    -> [LintedType] -> LintM [LintedType]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM LintedType -> LintM LintedType
    lintType [LintedType]
    tys)

           ; when report_unsat $
             do { _ <- lintType expanded_ty
                ; return () }

           ; lint_ty_app ty (tyConKind tc) tys'
           ; return (TyConApp tc tys') }

      -- Otherwise this must be a type family
      | Bool
    otherwise
      = do { tys' <- (LintedType -> LintM LintedType)
    -> [LintedType] -> LintM [LintedType]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM LintedType -> LintM LintedType
    lintType [LintedType]
    tys
           ; lint_ty_app ty (tyConKind tc) tys'
           ; return (TyConApp tc tys') }

    -----------------
    -- Confirms that a type is really TYPE r or Constraint
    checkValueType :: LintedType -> SDoc -> LintM ()
    checkValueType :: LintedType -> SDoc -> LintM ()
    checkValueType LintedType
    ty SDoc
    doc
      = Bool -> SDoc -> LintM ()
    lintL (LintedType -> Bool
    isTYPEorCONSTRAINT LintedType
    kind)
              (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-Type-like kind when Type-like expected:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kind SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "when checking" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    doc)
      where
        kind :: LintedType
    kind = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty

    -----------------
    lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM ()
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM ()
    lintArrow SDoc
    what LintedType
    t1 LintedType
    t2 LintedType
    tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw
                             -- or lintArrow "coercion `blah'" k1 k2 kw
      = do { Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType -> Bool
    isTYPEorCONSTRAINT LintedType
    k1) (SDoc -> LintedType -> LintM ()
    report (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "argument") LintedType
    k1)
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType -> Bool
    isTYPEorCONSTRAINT LintedType
    k2) (SDoc -> LintedType -> LintM ()
    report (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "result")   LintedType
    k2)
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType -> Bool
    isMultiplicityTy LintedType
    kw)         (SDoc -> LintedType -> LintM ()
    report (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "multiplicity") LintedType
    kw) }
      where
        k1 :: LintedType
    k1 = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t1
        k2 :: LintedType
    k2 = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t2
        kw :: LintedType
    kw = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    tw
        report :: SDoc -> LintedType -> LintM ()
    report SDoc
    ar LintedType
    k = SDoc -> LintM ()
    addErrL ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Ill-kinded" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    ar)
                                         JoinArity
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "in" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    what)
                                    , SDoc
    what SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "kind:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    k ])

    -----------------
    lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()
    lint_ty_app :: LintedType -> LintedType -> [LintedType] -> LintM ()
    lint_ty_app LintedType
    msg_ty LintedType
    k [LintedType]
    tys
        -- See Note [Avoiding compiler perf traps when constructing error messages.]
      = (LintedType -> SDoc)
    -> LintedType -> LintedType -> [LintedType] -> LintM ()
    forall msg_thing.
    Outputable msg_thing =>
    (msg_thing -> SDoc)
    -> msg_thing -> LintedType -> [LintedType] -> LintM ()
    lint_app (\LintedType
    msg_ty -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "type" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    msg_ty)) LintedType
    msg_ty LintedType
    k [LintedType]
    tys

    ----------------
    lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()
    lint_co_app :: Coercion -> LintedType -> [LintedType] -> LintM ()
    lint_co_app Coercion
    msg_ty LintedType
    k [LintedType]
    tys
        -- See Note [Avoiding compiler perf traps when constructing error messages.]
      = (Coercion -> SDoc)
    -> Coercion -> LintedType -> [LintedType] -> LintM ()
    forall msg_thing.
    Outputable msg_thing =>
    (msg_thing -> SDoc)
    -> msg_thing -> LintedType -> [LintedType] -> LintM ()
    lint_app (\Coercion
    msg_ty -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "coercion" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    msg_ty)) Coercion
    msg_ty LintedType
    k [LintedType]
    tys

    ----------------
    lintTyLit :: TyLit -> LintM ()
    lintTyLit :: TyLit -> LintM ()
    lintTyLit (NumTyLit Integer
    n)
      | Integer
    n Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Integer
    0    = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      | Bool
    otherwise = SDoc -> LintM ()
    forall a. SDoc -> LintM a
    failWithL SDoc
    msg
        where msg :: SDoc
    msg = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Negative type literal:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Integer -> SDoc
    forall doc. IsLine doc => Integer -> doc
    integer Integer
    n
    lintTyLit (StrTyLit FastString
    _) = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    lintTyLit (CharTyLit Char
    _) = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    lint_app :: Outputable msg_thing => (msg_thing -> SDoc) -> msg_thing -> LintedKind -> [LintedType] -> LintM ()
    -- (lint_app d fun_kind arg_tys)
    --    We have an application (f arg_ty1 .. arg_tyn),
    --    where f :: fun_kind

    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    --
    -- Being strict in the kind here avoids quite a few pointless thunks
    -- reducing allocations by ~5%
    lint_app :: forall msg_thing.
    Outputable msg_thing =>
    (msg_thing -> SDoc)
    -> msg_thing -> LintedType -> [LintedType] -> LintM ()
    lint_app msg_thing -> SDoc
    mk_msg msg_thing
    msg_type !LintedType
    kfn [LintedType]
    arg_tys
        = do { !in_scope <- LintM InScopeSet
    getInScope
             -- We need the in_scope set to satisfy the invariant in
             -- Note [The substitution invariant] in GHC.Core.TyCo.Subst
             -- Forcing the in scope set eagerly here reduces allocations by up to 4%.
             ; go_app in_scope kfn arg_tys
             }
      where

        -- We use explicit recursion instead of a fold here to avoid go_app becoming
        -- an allocated function closure. This reduced allocations by up to 7% for some
        -- modules.
        go_app :: InScopeSet -> LintedKind -> [Type] -> LintM ()
        go_app :: InScopeSet -> LintedType -> [LintedType] -> LintM ()
    go_app !InScopeSet
    in_scope !LintedType
    kfn [LintedType]
    ta
          | Just LintedType
    kfn' <- LintedType -> Maybe LintedType
    coreView LintedType
    kfn
          = InScopeSet -> LintedType -> [LintedType] -> LintM ()
    go_app InScopeSet
    in_scope LintedType
    kfn' [LintedType]
    ta

        go_app InScopeSet
    _in_scope LintedType
    _kind [] = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        go_app InScopeSet
    in_scope fun_kind :: LintedType
    fun_kind@(FunTy FunTyFlag
    _ LintedType
    _ LintedType
    kfa LintedType
    kfb) (LintedType
    ta:[LintedType]
    tas)
          = do { let ka :: LintedType
    ka = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ta
               ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    ka HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    kfa) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                 SDoc -> LintM ()
    addErrL (LintedType
    -> [LintedType] -> (msg_thing -> SDoc) -> msg_thing -> SDoc -> SDoc
    forall a1 a2 t.
    (Outputable a1, Outputable a2) =>
    a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc
    lint_app_fail_msg LintedType
    kfn [LintedType]
    arg_tys msg_thing -> SDoc
    mk_msg msg_thing
    msg_type (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Fun:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    fun_kind SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ta SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ka)))
               ; InScopeSet -> LintedType -> [LintedType] -> LintM ()
    go_app InScopeSet
    in_scope LintedType
    kfb [LintedType]
    tas }

        go_app InScopeSet
    in_scope (ForAllTy (Bndr Var
    kv ForAllTyFlag
    _vis) LintedType
    kfn) (LintedType
    ta:[LintedType]
    tas)
          = do { let kv_kind :: LintedType
    kv_kind = Var -> LintedType
    varType Var
    kv
                     ka :: LintedType
    ka      = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ta
               ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    ka HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    kv_kind) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                 SDoc -> LintM ()
    addErrL (LintedType
    -> [LintedType] -> (msg_thing -> SDoc) -> msg_thing -> SDoc -> SDoc
    forall a1 a2 t.
    (Outputable a1, Outputable a2) =>
    a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc
    lint_app_fail_msg LintedType
    kfn [LintedType]
    arg_tys msg_thing -> SDoc
    mk_msg msg_thing
    msg_type (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Forall:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    kv SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kv_kind SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                                                        LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ta SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ka)))
               ; let kind' :: LintedType
    kind' = HasDebugCallStack => Subst -> LintedType -> LintedType
    Subst -> LintedType -> LintedType
    substTy (Subst -> Var -> LintedType -> Subst
    extendTCvSubst (InScopeSet -> Subst
    mkEmptySubst InScopeSet
    in_scope) Var
    kv LintedType
    ta) LintedType
    kfn
               ; InScopeSet -> LintedType -> [LintedType] -> LintM ()
    go_app InScopeSet
    in_scope LintedType
    kind' [LintedType]
    tas }

        go_app InScopeSet
    _ LintedType
    kfn [LintedType]
    ta
           = SDoc -> LintM ()
    forall a. SDoc -> LintM a
    failWithL (LintedType
    -> [LintedType] -> (msg_thing -> SDoc) -> msg_thing -> SDoc -> SDoc
    forall a1 a2 t.
    (Outputable a1, Outputable a2) =>
    a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc
    lint_app_fail_msg LintedType
    kfn [LintedType]
    arg_tys msg_thing -> SDoc
    mk_msg msg_thing
    msg_type (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Not a fun:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kfn SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [LintedType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [LintedType]
    ta)))

    -- This is a top level definition to ensure we pass all variables of the error message
    -- explicitly and don't capture them as free variables. Otherwise this binder might
    -- become a thunk that get's allocated in the hot code path.
    -- See Note [Avoiding compiler perf traps when constructing error messages.]
    lint_app_fail_msg :: (Outputable a1, Outputable a2) => a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc
    lint_app_fail_msg :: forall a1 a2 t.
    (Outputable a1, Outputable a2) =>
    a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc
    lint_app_fail_msg a1
    kfn a2
    arg_tys t -> SDoc
    mk_msg t
    msg_type SDoc
    extra = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Kind application error in") JoinArity
    2 (t -> SDoc
    mk_msg t
    msg_type)
                          , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Function kind =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> a1 -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr a1
    kfn)
                          , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arg types =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> a2 -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr a2
    arg_tys)
                          , SDoc
    extra ]
    {- *********************************************************************
    *                                                                      *
            Linting rules
    *                                                                      *
    ********************************************************************* -}

    lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM ()
    lintCoreRule :: Var -> LintedType -> CoreRule -> LintM ()
    lintCoreRule Var
    _ LintedType
    _ (BuiltinRule {})
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()  -- Don't bother

    lintCoreRule Var
    fun LintedType
    fun_ty rule :: CoreRule
    rule@(Rule { ru_name :: CoreRule -> FastString
    ru_name = FastString
    name, ru_bndrs :: CoreRule -> [Var]
    ru_bndrs = [Var]
    bndrs
                                       , ru_args :: CoreRule -> [CoreExpr]
    ru_args = [CoreExpr]
    args, ru_rhs :: CoreRule -> CoreExpr
    ru_rhs = CoreExpr
    rhs })
      = BindingSite -> [Var] -> ([Var] -> LintM ()) -> LintM ()
    forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintBinders BindingSite
    LambdaBind [Var]
    bndrs (([Var] -> LintM ()) -> LintM ())
    -> ([Var] -> LintM ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \ [Var]
    _ ->
        do { (lhs_ty, _) <- (LintedType, UsageEnv)
    -> [CoreExpr] -> LintM (LintedType, UsageEnv)
    lintCoreArgs (LintedType
    fun_ty, UsageEnv
    zeroUE) [CoreExpr]
    args
           ; (rhs_ty, _) <- case idJoinPointHood fun of
                         JoinPoint JoinArity
    join_arity
                           -> do { Bool -> SDoc -> LintM ()
    checkL ([CoreExpr]
    args [CoreExpr] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthIs` JoinArity
    join_arity) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                                    Var -> JoinArity -> CoreRule -> SDoc
    mkBadJoinPointRuleMsg Var
    fun JoinArity
    join_arity CoreRule
    rule
                                   -- See Note [Rules for join points]
                                 ; CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    rhs }
                         JoinPointHood
    _ -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintM a -> LintM a
    markAllJoinsBad (LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    rhs
           ; ensureEqTys lhs_ty rhs_ty $
             (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty
                                , text "rhs type:" <+> ppr rhs_ty
                                , text "fun_ty:" <+> ppr fun_ty ])
           ; let bad_bndrs = (Var -> Bool) -> [Var] -> [Var]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Var -> Bool
    is_bad_bndr [Var]
    bndrs

           ; checkL (null bad_bndrs)
                    (rule_doc <+> text "unbound" <+> ppr bad_bndrs)
                -- See Note [Linting rules]
        }
      where
        rule_doc :: SDoc
    rule_doc = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Rule" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    doubleQuotes (FastString -> SDoc
    forall doc. IsLine doc => FastString -> doc
    ftext FastString
    name) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon

        lhs_fvs :: IdSet
    lhs_fvs = [CoreExpr] -> IdSet
    exprsFreeVars [CoreExpr]
    args
        rhs_fvs :: IdSet
    rhs_fvs = CoreExpr -> IdSet
    exprFreeVars CoreExpr
    rhs

        is_bad_bndr :: Var -> Bool
        -- See Note [Unbound RULE binders] in GHC.Core.Rules
        is_bad_bndr :: Var -> Bool
    is_bad_bndr Var
    bndr = Bool -> Bool
    not (Var
    bndr Var -> IdSet -> Bool
    `elemVarSet` IdSet
    lhs_fvs)
                        Bool -> Bool -> Bool
    && Var
    bndr Var -> IdSet -> Bool
    `elemVarSet` IdSet
    rhs_fvs
                        Bool -> Bool -> Bool
    && Maybe Coercion -> Bool
    forall a. Maybe a -> Bool
    isNothing (Var -> Maybe Coercion
    isReflCoVar_maybe Var
    bndr)

    {- Note [Linting rules]
    ~~~~~~~~~~~~~~~~~~~~~~~
    It's very bad if simplifying a rule means that one of the template
    variables (ru_bndrs) that /is/ mentioned on the RHS becomes
    not-mentioned in the LHS (ru_args).  How can that happen?  Well, in #10602,
    SpecConstr stupidly constructed a rule like

      forall x,c1,c2.
         f (x |> c1 |> c2) = ....

    But simplExpr collapses those coercions into one.  (Indeed in #10602,
    it collapsed to the identity and was removed altogether.)

    We don't have a great story for what to do here, but at least
    this check will nail it.

    NB (#11643): it's possible that a variable listed in the
    binders becomes not-mentioned on both LHS and RHS.  Here's a silly
    example:
       RULE forall x y. f (g x y) = g (x+1) (y-1)
    And suppose worker/wrapper decides that 'x' is Absent.  Then
    we'll end up with
       RULE forall x y. f ($gw y) = $gw (x+1)
    This seems sufficiently obscure that there isn't enough payoff to
    try to trim the forall'd binder list.

    Note [Rules for join points]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    A join point cannot be partially applied. However, the left-hand side of a rule
    for a join point is effectively a *pattern*, not a piece of code, so there's an
    argument to be made for allowing a situation like this:

      join $sj :: Int -> Int -> String
           $sj n m = ...
           j :: forall a. Eq a => a -> a -> String
           {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}
           j @a $dEq x y = ...

    Applying this rule can't turn a well-typed program into an ill-typed one, so
    conceivably we could allow it. But we can always eta-expand such an
    "undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact
    the simplifier would have to in order to deal with the RHS. So we take a
    conservative view and don't allow undersaturated rules for join points. See
    Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion.
    -}

    {-
    ************************************************************************
    *                                                                      *
             Linting coercions
    *                                                                      *
    ************************************************************************
    -}

    {- Note [Asymptotic efficiency]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When linting coercions (and types actually) we return a linted
    (substituted) coercion.  Then we often have to take the coercionKind of
    that returned coercion. If we get long chains, that can be asymptotically
    inefficient, notably in
    * TransCo
    * InstCo
    * SelCo (cf #9233)
    * LRCo

    But the code is simple.  And this is only Lint.  Let's wait to see if
    the bad perf bites us in practice.

    A solution would be to return the kind and role of the coercion,
    as well as the linted coercion.  Or perhaps even *only* the kind and role,
    which is what used to happen.   But that proved tricky and error prone
    (#17923), so now we return the coercion.
    -}

    -- lints a coercion, confirming that its lh kind and its rh kind are both *
    -- also ensures that the role is Nominal
    lintStarCoercion :: InCoercion -> LintM LintedCoercion
    lintStarCoercion :: Coercion -> LintM Coercion
    lintStarCoercion Coercion
    g
      = do { g' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    g
           ; let Pair t1 t2 = coercionKind g'
           ; checkValueType t1 (text "the kind of the left type in" <+> ppr g)
           ; checkValueType t2 (text "the kind of the right type in" <+> ppr g)
           ; lintRole g Nominal (coercionRole g)
           ; return g' }

    lintCoercion :: InCoercion -> LintM LintedCoercion
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]

    lintCoercion :: Coercion -> LintM Coercion
    lintCoercion (CoVarCo Var
    cv)
      | Bool -> Bool
    not (Var -> Bool
    isCoVar Var
    cv)
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad CoVarCo:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    cv)
                      JoinArity
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "With offending type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    varType Var
    cv)))

      | Bool
    otherwise
      = do { subst <- LintM Subst
    getSubst
           ; case lookupCoVar subst cv of
               Just Coercion
    linted_co -> Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Coercion
    linted_co ;
               Maybe Coercion
    Nothing        -> do { Subst -> Var -> LintM ()
    checkTyCoVarInScope Subst
    subst Var
    cv
                                    ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> Coercion
    CoVarCo Var
    cv) }
         }

    lintCoercion (Refl LintedType
    ty)
      = do { ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; return (Refl ty') }

    lintCoercion (GRefl Role
    r LintedType
    ty MCoercion
    MRefl)
      = do { ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; return (GRefl r ty' MRefl) }

    lintCoercion (GRefl Role
    r LintedType
    ty (MCo Coercion
    co))
      = do { ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; co' <- lintCoercion co
           ; let tk = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty'
                 tl = HasDebugCallStack => Coercion -> LintedType
    Coercion -> LintedType
    coercionLKind Coercion
    co'
           ; ensureEqTys tk tl $
             hang (text "GRefl coercion kind mis-match:" <+> ppr co)
                2 (vcat [ppr ty', ppr tk, ppr tl])
           ; lintRole co' Nominal (coercionRole co')
           ; return (GRefl r ty' (MCo co')) }

    lintCoercion co :: Coercion
    co@(TyConAppCo Role
    r TyCon
    tc [Coercion]
    cos)
      | Just {} <- HasDebugCallStack => Role -> TyCon -> [Coercion] -> Maybe Coercion
    Role -> TyCon -> [Coercion] -> Maybe Coercion
    tyConAppFunCo_maybe Role
    r TyCon
    tc [Coercion]
    cos
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Saturated application of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc))
                      JoinArity
    2 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co))
        -- All saturated TyConAppCos should be FunCos

      | Just {} <- TyCon -> Maybe ([Var], LintedType)
    synTyConDefn_maybe TyCon
    tc
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Synonym in TyConAppCo:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)

      | Bool
    otherwise
      = do { TyCon -> LintM ()
    checkTyCon TyCon
    tc
           ; cos' <- (Coercion -> LintM Coercion) -> [Coercion] -> LintM [Coercion]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Coercion -> LintM Coercion
    lintCoercion [Coercion]
    cos
           ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos')
           ; lint_co_app co (tyConKind tc) (map pFst co_kinds)
           ; lint_co_app co (tyConKind tc) (map pSnd co_kinds)
           ; zipWithM_ (lintRole co) (tyConRoleListX r tc) co_roles
           ; return (TyConAppCo r tc cos') }

    lintCoercion co :: Coercion
    co@(AppCo Coercion
    co1 Coercion
    co2)
      | TyConAppCo {} <- Coercion
    co1
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "TyConAppCo to the left of AppCo:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)
      | Just (TyConApp {}, Role
    _) <- Coercion -> Maybe (LintedType, Role)
    isReflCo_maybe Coercion
    co1
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Refl (TyConApp ...) to the left of AppCo:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)
      | Bool
    otherwise
      = do { co1' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co1
           ; co2' <- lintCoercion co2
           ; let (Pair lk1 rk1, r1) = coercionKindRole co1'
                 (Pair lk2 rk2, r2) = coercionKindRole co2'
           ; lint_co_app co (typeKind lk1) [lk2]
           ; lint_co_app co (typeKind rk1) [rk2]

           ; if r1 == Phantom
             then lintL (r2 == Phantom || r2 == Nominal)
                         (text "Second argument in AppCo cannot be R:" $$
                          ppr co)
             else lintRole co Nominal r2

           ; return (AppCo co1' co2') }

    ----------
    lintCoercion co :: Coercion
    co@(ForAllCo { fco_tcv :: Coercion -> Var
    fco_tcv = Var
    tcv, fco_visL :: Coercion -> ForAllTyFlag
    fco_visL = ForAllTyFlag
    visL, fco_visR :: Coercion -> ForAllTyFlag
    fco_visR = ForAllTyFlag
    visR
                              , fco_kind :: Coercion -> Coercion
    fco_kind = Coercion
    kind_co, fco_body :: Coercion -> Coercion
    fco_body = Coercion
    body_co })
    -- See Note [ForAllCo] in GHC.Core.TyCo.Rep,
    -- including the typing rule for ForAllCo

      | Bool -> Bool
    not (Var -> Bool
    isTyCoVar Var
    tcv)
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non tyco binder in ForAllCo:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)

      | Bool
    otherwise
      = do { kind_co' <- Coercion -> LintM Coercion
    lintStarCoercion Coercion
    kind_co
           ; lintTyCoBndr tcv $ \Var
    tcv' ->
        do { body_co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    body_co
           ; ensureEqTys (varType tcv') (coercionLKind kind_co') $
             text "Kind mis-match in ForallCo" <+> ppr co

           -- Assuming kind_co :: k1 ~ k2
           -- Need to check that
           --    (forall (tcv:k1). lty) and
           --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])
           -- are both well formed.  Easiest way is to call lintForAllBody
           -- for each; there is actually no need to do the funky substitution
           ; let (Pair lty rty, body_role) = coercionKindRole body_co'
           ; lintForAllBody tcv' lty
           ; lintForAllBody tcv' rty

           ; when (isCoVar tcv) $
             do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $
                  text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co
                  -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep
                ; lintL (almostDevoidCoVarOfCo tcv body_co) $
                  text "Covar can only appear in Refl and GRefl: " <+> ppr co
                  -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep
             }

           ; when (body_role == Nominal) $
             lintL (visL `eqForAllVis` visR) $
             text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co

           ; return (co { fco_tcv = tcv', fco_kind = kind_co', fco_body = body_co' }) } }

    lintCoercion co :: Coercion
    co@(FunCo { fco_role :: Coercion -> Role
    fco_role = Role
    r, fco_afl :: Coercion -> FunTyFlag
    fco_afl = FunTyFlag
    afl, fco_afr :: Coercion -> FunTyFlag
    fco_afr = FunTyFlag
    afr
                           , fco_mult :: Coercion -> Coercion
    fco_mult = Coercion
    cow, fco_arg :: Coercion -> Coercion
    fco_arg = Coercion
    co1, fco_res :: Coercion -> Coercion
    fco_res = Coercion
    co2 })
      = do { co1' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co1
           ; co2' <- lintCoercion co2
           ; cow' <- lintCoercion cow
           ; let Pair lt1 rt1 = coercionKind co1
                 Pair lt2 rt2 = coercionKind co2
                 Pair ltw rtw = coercionKind cow
           ; lintL (afl == chooseFunTyFlag lt1 lt2) (bad_co_msg "afl")
           ; lintL (afr == chooseFunTyFlag rt1 rt2) (bad_co_msg "afr")
           ; lintArrow (bad_co_msg "arrowl") lt1 lt2 ltw
           ; lintArrow (bad_co_msg "arrowr") rt1 rt2 rtw
           ; lintRole co1 r (coercionRole co1)
           ; lintRole co2 r (coercionRole co2)
           ; ensureEqTys (typeKind ltw) multiplicityTy (bad_co_msg "mult-l")
           ; ensureEqTys (typeKind rtw) multiplicityTy (bad_co_msg "mult-r")
           ; let expected_mult_role = case Role
    r of
                                        Role
    Phantom -> Role
    Phantom
                                        Role
    _ -> Role
    Nominal
           ; lintRole cow expected_mult_role (coercionRole cow)
           ; return (co { fco_mult = cow', fco_arg = co1', fco_res = co2' }) }
      where
        bad_co_msg :: String -> SDoc
    bad_co_msg String
    s = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad coercion" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    s))
                          JoinArity
    2 ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "afl:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> FunTyFlag -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FunTyFlag
    afl
                                  , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "afr:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> FunTyFlag -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FunTyFlag
    afr
                                  , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "arg_co:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co1
                                  , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "res_co:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co2 ])

    -- See Note [Bad unsafe coercion]
    lintCoercion co :: Coercion
    co@(UnivCo { uco_role :: Coercion -> Role
    uco_role = Role
    r, uco_prov :: Coercion -> UnivCoProvenance
    uco_prov = UnivCoProvenance
    prov
                            , uco_lty :: Coercion -> LintedType
    uco_lty = LintedType
    ty1, uco_rty :: Coercion -> LintedType
    uco_rty = LintedType
    ty2, uco_deps :: Coercion -> [Coercion]
    uco_deps = [Coercion]
    deps })
      = do { -- Check the role.  PhantomProv must have Phantom role, otherwise any role is fine
             case UnivCoProvenance
    prov of
                UnivCoProvenance
    PhantomProv -> Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co Role
    Phantom Role
    r
                UnivCoProvenance
    _           -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

           -- Check the to and from types
           ; ty1' <- LintedType -> LintM LintedType
    lintType LintedType
    ty1
           ; ty2' <- lintType ty2

           ; let k1 = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty1'
                 k2 = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty2'
           ; when (r /= Phantom && isTYPEorCONSTRAINT k1
                                && isTYPEorCONSTRAINT k2)
                  (checkTypes ty1 ty2)

           -- Check the coercions on which this UnivCo depends
           ; deps' <- mapM lintCoercion deps

           ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = deps' }) }
       where
         report :: String -> SDoc
    report String
    s = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsafe coercion: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s)
                         JoinArity
    2 ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "From:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty1
                                 , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "  To:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty2])
         isUnBoxed :: PrimRep -> Bool
         isUnBoxed :: PrimRep -> Bool
    isUnBoxed = Bool -> Bool
    not (Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . PrimRep -> Bool
    isGcPtrRep

           -- see #9122 for discussion of these checks
         checkTypes :: LintedType -> LintedType -> LintM ()
    checkTypes LintedType
    t1 LintedType
    t2
           = do { Bool -> SDoc -> LintM ()
    checkWarnL Bool
    fixed_rep_1
                             (String -> SDoc
    report String
    "left-hand type does not have a fixed runtime representation")
                ; Bool -> SDoc -> LintM ()
    checkWarnL Bool
    fixed_rep_2
                             (String -> SDoc
    report String
    "right-hand type does not have a fixed runtime representation")
                ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool
    fixed_rep_1 Bool -> Bool -> Bool
    && Bool
    fixed_rep_2) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                  do { Bool -> SDoc -> LintM ()
    checkWarnL ([PrimRep]
    reps1 [PrimRep] -> [PrimRep] -> Bool
    forall a b. [a] -> [b] -> Bool
    `equalLength` [PrimRep]
    reps2)
                                  (String -> SDoc
    report String
    "between values with different # of reps")
                     ; (PrimRep -> PrimRep -> LintM ())
    -> [PrimRep] -> [PrimRep] -> LintM ()
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m ()
    zipWithM_ PrimRep -> PrimRep -> LintM ()
    validateCoercion [PrimRep]
    reps1 [PrimRep]
    reps2 }}
           where
             fixed_rep_1 :: Bool
    fixed_rep_1 = HasDebugCallStack => LintedType -> Bool
    LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    t1
             fixed_rep_2 :: Bool
    fixed_rep_2 = HasDebugCallStack => LintedType -> Bool
    LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    t2

             -- don't look at these unless lev_poly1/2 are False
             -- Otherwise, we get #13458
             reps1 :: [PrimRep]
    reps1 = HasDebugCallStack => LintedType -> [PrimRep]
    LintedType -> [PrimRep]
    typePrimRep LintedType
    t1
             reps2 :: [PrimRep]
    reps2 = HasDebugCallStack => LintedType -> [PrimRep]
    LintedType -> [PrimRep]
    typePrimRep LintedType
    t2

         validateCoercion :: PrimRep -> PrimRep -> LintM ()
         validateCoercion :: PrimRep -> PrimRep -> LintM ()
    validateCoercion PrimRep
    rep1 PrimRep
    rep2
           = do { platform <- LintM Platform
    getPlatform
                ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
                             (report "between unboxed and boxed value")
                ; checkWarnL (TyCon.primRepSizeB platform rep1
                               == TyCon.primRepSizeB platform rep2)
                             (report "between unboxed values of different size")
                ; let fl = (Bool -> Bool -> Bool) -> Maybe Bool -> Maybe Bool -> Maybe Bool
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 Bool -> Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    (==) (PrimRep -> Maybe Bool
    TyCon.primRepIsFloat PrimRep
    rep1)
                                       (PrimRep -> Maybe Bool
    TyCon.primRepIsFloat PrimRep
    rep2)
                ; case fl of
                    Maybe Bool
    Nothing    -> SDoc -> LintM ()
    addWarnL (String -> SDoc
    report String
    "between vector types")
                    Just Bool
    False -> SDoc -> LintM ()
    addWarnL (String -> SDoc
    report String
    "between float and integral values")
                    Maybe Bool
    _          -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                }

    lintCoercion (SymCo Coercion
    co)
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; return (SymCo co') }

    lintCoercion co :: Coercion
    co@(TransCo Coercion
    co1 Coercion
    co2)
      = do { co1' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co1
           ; co2' <- lintCoercion co2
           ; let ty1b = HasDebugCallStack => Coercion -> LintedType
    Coercion -> LintedType
    coercionRKind Coercion
    co1'
                 ty2a = HasDebugCallStack => Coercion -> LintedType
    Coercion -> LintedType
    coercionLKind Coercion
    co2'
           ; ensureEqTys ty1b ty2a
                   (hang (text "Trans coercion mis-match:" <+> ppr co)
                       2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')]))
           ; lintRole co (coercionRole co1) (coercionRole co2)
           ; return (TransCo co1' co2') }

    lintCoercion the_co :: Coercion
    the_co@(SelCo CoSel
    cs Coercion
    co)
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let (Pair s t, co_role) = coercionKindRole co'

           ; if -- forall (both TyVar and CoVar)
                | Just _ <- splitForAllTyCoVar_maybe s
                , Just _ <- splitForAllTyCoVar_maybe t
                , SelForAll <- cs
                ,   (isForAllTy_ty s && isForAllTy_ty t)
                 || (isForAllTy_co s && isForAllTy_co t)
                -> return (SelCo cs co')

                -- function
                | isFunTy s
                , isFunTy t
                , SelFun {} <- cs
                -> return (SelCo cs co')

                -- TyCon
                | Just (tc_s, tys_s) <- splitTyConApp_maybe s
                , Just (tc_t, tys_t) <- splitTyConApp_maybe t
                , tc_s == tc_t
                , SelTyCon n r0 <- cs
                , isInjectiveTyCon tc_s co_role
                    -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep
                , tys_s `equalLength` tys_t
                , tys_s `lengthExceeds` n
                -> do { lintRole the_co (tyConRole co_role tc_s n) r0
                      ; return (SelCo cs co') }

                | otherwise
                -> failWithL (hang (text "Bad SelCo:")
                                 2 (ppr the_co $$ ppr s $$ ppr t)) }

    lintCoercion the_co :: Coercion
    the_co@(LRCo LeftOrRight
    lr Coercion
    co)
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let Pair s t = coercionKind co'
                 r        = Coercion -> Role
    coercionRole Coercion
    co'
           ; lintRole co Nominal r
           ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
               (Just (LintedType, LintedType)
    _, Just (LintedType, LintedType)
    _) -> Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LeftOrRight -> Coercion -> Coercion
    LRCo LeftOrRight
    lr Coercion
    co')
               (Maybe (LintedType, LintedType), Maybe (LintedType, LintedType))
    _ -> SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad LRCo:")
                                  JoinArity
    2 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    the_co SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    s SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    t)) }

    lintCoercion (InstCo Coercion
    co Coercion
    arg)
      = do { co'  <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; arg' <- lintCoercion arg
           ; let Pair t1 t2 = coercionKind co'
                 Pair s1 s2 = coercionKind arg'

           ; lintRole arg Nominal (coercionRole arg')

          ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of
             -- forall over tvar
             { (Just (Var
    tv1,LintedType
    _), Just (Var
    tv2,LintedType
    _))
                 | HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s1 HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` Var -> LintedType
    tyVarKind Var
    tv1
                 , HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s2 HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` Var -> LintedType
    tyVarKind Var
    tv2
                 -> Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion -> Coercion
    InstCo Coercion
    co' Coercion
    arg')
                 | Bool
    otherwise
                 -> SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Kind mis-match in inst coercion1" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)

             ; (Maybe (Var, LintedType), Maybe (Var, LintedType))
    _ -> case (LintedType -> Maybe (Var, LintedType)
    splitForAllCoVar_maybe LintedType
    t1, LintedType -> Maybe (Var, LintedType)
    splitForAllCoVar_maybe LintedType
    t2) of
             -- forall over covar
             { (Just (Var
    cv1, LintedType
    _), Just (Var
    cv2, LintedType
    _))
                 | HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s1 HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` Var -> LintedType
    varType Var
    cv1
                 , HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s2 HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` Var -> LintedType
    varType Var
    cv2
                 , CoercionTy Coercion
    _ <- LintedType
    s1
                 , CoercionTy Coercion
    _ <- LintedType
    s2
                 -> Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion -> Coercion
    InstCo Coercion
    co' Coercion
    arg')
                 | Bool
    otherwise
                 -> SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Kind mis-match in inst coercion2" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)

             ; (Maybe (Var, LintedType), Maybe (Var, LintedType))
    _ -> SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad argument of inst") }}}

    lintCoercion this_co :: Coercion
    this_co@(AxiomCo CoAxiomRule
    ax [Coercion]
    cos)
      = do { cos' <- (Coercion -> LintM Coercion) -> [Coercion] -> LintM [Coercion]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Coercion -> LintM Coercion
    lintCoercion [Coercion]
    cos
           ; let arg_kinds :: [Pair Type] = map coercionKind cos'
           ; lint_roles 0 (coAxiomRuleArgRoles ax) cos'
           ; lint_ax ax arg_kinds
           ; return (AxiomCo ax cos') }
      where
        lint_ax :: CoAxiomRule -> [Pair Type] -> LintM ()
        lint_ax :: CoAxiomRule -> [Pair LintedType] -> LintM ()
    lint_ax (BuiltInFamRew  BuiltInFamRewrite
    bif) [Pair LintedType]
    prs
          = Bool -> SDoc -> LintM ()
    checkL (Maybe (Pair LintedType) -> Bool
    forall a. Maybe a -> Bool
    isJust (BuiltInFamRewrite -> [Pair LintedType] -> Maybe (Pair LintedType)
    bifrw_proves BuiltInFamRewrite
    bif [Pair LintedType]
    prs))  SDoc
    bad_bif
        lint_ax (BuiltInFamInj BuiltInFamInjectivity
    bif) [Pair LintedType]
    prs
          = Bool -> SDoc -> LintM ()
    checkL (case [Pair LintedType]
    prs of
                      [Pair LintedType
    pr] -> Maybe (Pair LintedType) -> Bool
    forall a. Maybe a -> Bool
    isJust (BuiltInFamInjectivity -> Pair LintedType -> Maybe (Pair LintedType)
    bifinj_proves BuiltInFamInjectivity
    bif Pair LintedType
    pr)
                      [Pair LintedType]
    _    -> Bool
    False)
                   SDoc
    bad_bif
        lint_ax (UnbranchedAxiom CoAxiom Unbranched
    ax) [Pair LintedType]
    prs
          = Coercion -> TyCon -> CoAxBranch -> [Pair LintedType] -> LintM ()
    lintBranch Coercion
    this_co (CoAxiom Unbranched -> TyCon
    forall (br :: BranchFlag). CoAxiom br -> TyCon
    coAxiomTyCon CoAxiom Unbranched
    ax) (CoAxiom Unbranched -> CoAxBranch
    coAxiomSingleBranch CoAxiom Unbranched
    ax) [Pair LintedType]
    prs
        lint_ax (BranchedAxiom CoAxiom Branched
    ax JoinArity
    ind) [Pair LintedType]
    prs
          = do { Bool -> SDoc -> LintM ()
    checkL (JoinArity
    0 JoinArity -> JoinArity -> Bool
    forall a. Ord a => a -> a -> Bool
    <= JoinArity
    ind Bool -> Bool -> Bool
    && JoinArity
    ind JoinArity -> JoinArity -> Bool
    forall a. Ord a => a -> a -> Bool
    < Branches Branched -> JoinArity
    forall (br :: BranchFlag). Branches br -> JoinArity
    numBranches (CoAxiom Branched -> Branches Branched
    forall (br :: BranchFlag). CoAxiom br -> Branches br
    coAxiomBranches CoAxiom Branched
    ax))
                        (Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "index out of range"))
               ; Coercion -> TyCon -> CoAxBranch -> [Pair LintedType] -> LintM ()
    lintBranch Coercion
    this_co (CoAxiom Branched -> TyCon
    forall (br :: BranchFlag). CoAxiom br -> TyCon
    coAxiomTyCon CoAxiom Branched
    ax) (CoAxiom Branched -> JoinArity -> CoAxBranch
    forall (br :: BranchFlag). CoAxiom br -> JoinArity -> CoAxBranch
    coAxiomNthBranch CoAxiom Branched
    ax JoinArity
    ind) [Pair LintedType]
    prs }

        bad_bif :: SDoc
    bad_bif = Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Proves returns Nothing")

        err :: forall a. String -> [SDoc] -> LintM a
        err :: forall a. String -> [SDoc] -> LintM a
    err String
    m [SDoc]
    xs  = SDoc -> LintM a
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM a) -> SDoc -> LintM a
    forall a b. (a -> b) -> a -> b
    $
                    SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    m) JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Rule:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoAxiomRule -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiomRule
    ax SDoc -> [SDoc] -> [SDoc]
    forall a. a -> [a] -> [a]
    : [SDoc]
    xs)

        lint_roles :: JoinArity -> [Role] -> [Coercion] -> LintM ()
    lint_roles JoinArity
    n (Role
    e : [Role]
    es) (Coercion
    co : [Coercion]
    cos)
          | Role
    e Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Coercion -> Role
    coercionRole Coercion
    co
          = JoinArity -> [Role] -> [Coercion] -> LintM ()
    lint_roles (JoinArity
    nJoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    +JoinArity
    1) [Role]
    es [Coercion]
    cos
          | Bool
    otherwise = String -> [SDoc] -> LintM ()
    forall a. String -> [SDoc] -> LintM a
    err String
    "Argument roles mismatch"
                            [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In argument:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall doc. IsLine doc => JoinArity -> doc
    int (JoinArity
    nJoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    +JoinArity
    1)
                            , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Expected:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Role
    e
                            , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Found:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Coercion -> Role
    coercionRole Coercion
    co) ]
        lint_roles JoinArity
    _ [] []  = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        lint_roles JoinArity
    n [] [Coercion]
    rs  = String -> [SDoc] -> LintM ()
    forall a. String -> [SDoc] -> LintM a
    err String
    "Too many coercion arguments"
                                [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Expected:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall doc. IsLine doc => JoinArity -> doc
    int JoinArity
    n
                                , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Provided:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall doc. IsLine doc => JoinArity -> doc
    int (JoinArity
    n JoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    + [Coercion] -> JoinArity
    forall a. [a] -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [Coercion]
    rs) ]

        lint_roles JoinArity
    n [Role]
    es []  = String -> [SDoc] -> LintM ()
    forall a. String -> [SDoc] -> LintM a
    err String
    "Not enough coercion arguments"
                                [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Expected:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall doc. IsLine doc => JoinArity -> doc
    int (JoinArity
    n JoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    + [Role] -> JoinArity
    forall a. [a] -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [Role]
    es)
                                , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Provided:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall doc. IsLine doc => JoinArity -> doc
    int JoinArity
    n ]

    lintCoercion (KindCo Coercion
    co)
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; return (KindCo co') }

    lintCoercion (SubCo Coercion
    co')
      = do { co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co'
           ; lintRole co' Nominal (coercionRole co')
           ; return (SubCo co') }

    lintCoercion (HoleCo CoercionHole
    h)
      = do { SDoc -> LintM ()
    addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Unfilled coercion hole:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoercionHole -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoercionHole
    h
           ; Coercion -> LintM Coercion
    lintCoercion (Var -> Coercion
    CoVarCo (CoercionHole -> Var
    coHoleCoVar CoercionHole
    h)) }

    {-
    Note [Conflict checking for axiom applications]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider the following type family and axiom:

    type family Equal (a :: k) (b :: k) :: Bool
    type instance where
      Equal a a = True
      Equal a b = False
    --
    Equal :: forall k::*. k -> k -> Bool
    axEqual :: { forall k::*. forall a::k. Equal k a a ~ True
               ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }

    The coercion (axEqual[1] <*> <Int> <Int) is ill-typed, and Lint should reject it.
    (Recall that the index is 0-based, so this is the second branch of the axiom.)
    The problem is that, on the surface, it seems that

      (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False)

    and that all is OK. But, all is not OK: we want to use the first branch of the
    axiom in this case, not the second. The problem is that the parameters of the
    first branch can unify with the supplied coercions, thus meaning that the first
    branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv".

    For more details, see the section "Branched axiom conflict checking" in
    docs/core-spec, which defines the corresponding no_conflict function used by the
    Co_AxiomInstCo rule in the section "Coercion typing".
    -}

    -- | Check to make sure that an axiom application is internally consistent.
    -- Returns the conflicting branch, if it exists
    -- Note [Conflict checking for axiom applications]
    lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM ()
    -- defined here to avoid dependencies in GHC.Core.Coercion
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism] in GHC.Core.Lint
    lintBranch :: Coercion -> TyCon -> CoAxBranch -> [Pair LintedType] -> LintM ()
    lintBranch Coercion
    this_co TyCon
    fam_tc CoAxBranch
    branch [Pair LintedType]
    arg_kinds
      | CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
    cab_tvs = [Var]
    ktvs, cab_cvs :: CoAxBranch -> [Var]
    cab_cvs = [Var]
    cvs } <- CoAxBranch
    branch
      = do { Bool -> SDoc -> LintM ()
    checkL ([Pair LintedType]
    arg_kinds [Pair LintedType] -> [Var] -> Bool
    forall a b. [a] -> [b] -> Bool
    `equalLength` ([Var]
    ktvs [Var] -> [Var] -> [Var]
    forall a. [a] -> [a] -> [a]
    ++ [Var]
    cvs)) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                    (Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "lengths"))

           ; subst <- LintM Subst
    getSubst
           ; let empty_subst = Subst -> Subst
    zapSubst Subst
    subst
           ; _ <- foldlM check_ki (empty_subst, empty_subst)
                                  (zip (ktvs ++ cvs) arg_kinds)

           ; case check_no_conflict flattened_target incomps of
                Maybe CoAxBranch
    Nothing -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just CoAxBranch
    bad_branch -> SDoc -> LintM ()
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                                   String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "inconsistent with" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
                                     TyCon -> CoAxBranch -> SDoc
    pprCoAxBranch TyCon
    fam_tc CoAxBranch
    bad_branch }
      where
        check_ki :: (Subst, Subst) -> (Var, Pair LintedType) -> LintM (Subst, Subst)
    check_ki (Subst
    subst_l, Subst
    subst_r) (Var
    ktv, Pair LintedType
    s' LintedType
    t')
          = do { let sk' :: LintedType
    sk' = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s'
                     tk' :: LintedType
    tk' = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t'
               ; let ktv_kind_l :: LintedType
    ktv_kind_l = HasDebugCallStack => Subst -> LintedType -> LintedType
    Subst -> LintedType -> LintedType
    substTy Subst
    subst_l (Var -> LintedType
    tyVarKind Var
    ktv)
                     ktv_kind_r :: LintedType
    ktv_kind_r = HasDebugCallStack => Subst -> LintedType -> LintedType
    Subst -> LintedType -> LintedType
    substTy Subst
    subst_r (Var -> LintedType
    tyVarKind Var
    ktv)
               ; Bool -> SDoc -> LintM ()
    checkL (LintedType
    sk' HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    ktv_kind_l)
                        (Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "check_ki1" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    this_co, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    sk', Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    ktv, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ktv_kind_l ] ))
               ; Bool -> SDoc -> LintM ()
    checkL (LintedType
    tk' HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    ktv_kind_r)
                        (Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "check_ki2" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    this_co, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    tk', Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    ktv, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ktv_kind_r ] ))
               ; (Subst, Subst) -> LintM (Subst, Subst)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Subst -> Var -> LintedType -> Subst
    extendTCvSubst Subst
    subst_l Var
    ktv LintedType
    s',
                         Subst -> Var -> LintedType -> Subst
    extendTCvSubst Subst
    subst_r Var
    ktv LintedType
    t') }

        tvs :: [Var]
    tvs          = CoAxBranch -> [Var]
    coAxBranchTyVars CoAxBranch
    branch
        cvs :: [Var]
    cvs          = CoAxBranch -> [Var]
    coAxBranchCoVars CoAxBranch
    branch
        incomps :: [CoAxBranch]
    incomps      = CoAxBranch -> [CoAxBranch]
    coAxBranchIncomps CoAxBranch
    branch
        ([LintedType]
    tys, [LintedType]
    cotys) = [Var] -> [LintedType] -> ([LintedType], [LintedType])
    forall b a. [b] -> [a] -> ([a], [a])
    splitAtList [Var]
    tvs ((Pair LintedType -> LintedType)
    -> [Pair LintedType] -> [LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map Pair LintedType -> LintedType
    forall a. Pair a -> a
    pFst [Pair LintedType]
    arg_kinds)
        co_args :: [Coercion]
    co_args      = (LintedType -> Coercion) -> [LintedType] -> [Coercion]
    forall a b. (a -> b) -> [a] -> [b]
    map LintedType -> Coercion
    stripCoercionTy [LintedType]
    cotys
        subst :: Subst
    subst        = [Var] -> [LintedType] -> Subst
    HasDebugCallStack => [Var] -> [LintedType] -> Subst
    zipTvSubst [Var]
    tvs [LintedType]
    tys Subst -> Subst -> Subst
    `composeTCvSubst`
                       [Var] -> [Coercion] -> Subst
    HasDebugCallStack => [Var] -> [Coercion] -> Subst
    zipCvSubst [Var]
    cvs [Coercion]
    co_args
        target :: [LintedType]
    target   = HasDebugCallStack => Subst -> [LintedType] -> [LintedType]
    Subst -> [LintedType] -> [LintedType]
    Type.substTys Subst
    subst (CoAxBranch -> [LintedType]
    coAxBranchLHS CoAxBranch
    branch)
        in_scope :: InScopeSet
    in_scope = IdSet -> InScopeSet
    mkInScopeSet (IdSet -> InScopeSet) -> IdSet -> InScopeSet
    forall a b. (a -> b) -> a -> b
    $
                   [IdSet] -> IdSet
    unionVarSets ((CoAxBranch -> IdSet) -> [CoAxBranch] -> [IdSet]
    forall a b. (a -> b) -> [a] -> [b]
    map ([LintedType] -> IdSet
    tyCoVarsOfTypes ([LintedType] -> IdSet)
    -> (CoAxBranch -> [LintedType]) -> CoAxBranch -> IdSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoAxBranch -> [LintedType]
    coAxBranchLHS) [CoAxBranch]
    incomps)
        flattened_target :: [LintedType]
    flattened_target = InScopeSet -> [LintedType] -> [LintedType]
    flattenTys InScopeSet
    in_scope [LintedType]
    target

        check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch
        check_no_conflict :: [LintedType] -> [CoAxBranch] -> Maybe CoAxBranch
    check_no_conflict [LintedType]
    _    [] = Maybe CoAxBranch
    forall a. Maybe a
    Nothing
        check_no_conflict [LintedType]
    flat (b :: CoAxBranch
    b@CoAxBranch { cab_lhs :: CoAxBranch -> [LintedType]
    cab_lhs = [LintedType]
    lhs_incomp } : [CoAxBranch]
    rest)
             -- See Note [Apartness] in GHC.Core.FamInstEnv
          | UnifyResultM Subst
    SurelyApart <- BindFun -> [LintedType] -> [LintedType] -> UnifyResultM Subst
    tcUnifyTysFG BindFun
    alwaysBindFun [LintedType]
    flat [LintedType]
    lhs_incomp
          = [LintedType] -> [CoAxBranch] -> Maybe CoAxBranch
    check_no_conflict [LintedType]
    flat [CoAxBranch]
    rest
          | Bool
    otherwise
          = CoAxBranch -> Maybe CoAxBranch
    forall a. a -> Maybe a
    Just CoAxBranch
    b

    bad_ax :: Coercion -> SDoc -> SDoc
    bad_ax :: Coercion -> SDoc -> SDoc
    bad_ax Coercion
    this_co SDoc
    what
        = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad axiom application" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens SDoc
    what) JoinArity
    2 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    this_co)

    {-
    ************************************************************************
    *                                                                      *
                  Axioms
    *                                                                      *
    ************************************************************************
    -}

    lintAxioms :: Logger
               -> LintConfig
               -> SDoc -- ^ The source of the linted axioms
               -> [CoAxiom Branched]
               -> IO ()
    lintAxioms :: Logger -> LintConfig -> SDoc -> [CoAxiom Branched] -> IO ()
    lintAxioms Logger
    logger LintConfig
    cfg SDoc
    what [CoAxiom Branched]
    axioms =
      Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
    displayLintResults Logger
    logger Bool
    True SDoc
    what ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ (CoAxiom Branched -> SDoc) -> [CoAxiom Branched] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map CoAxiom Branched -> SDoc
    forall (br :: BranchFlag). CoAxiom br -> SDoc
    pprCoAxiom [CoAxiom Branched]
    axioms) (WarnsAndErrs -> IO ()) -> WarnsAndErrs -> IO ()
    forall a b. (a -> b) -> a -> b
    $
      LintConfig -> LintM () -> WarnsAndErrs
    forall a. LintConfig -> LintM a -> WarnsAndErrs
    initL LintConfig
    cfg (LintM () -> WarnsAndErrs) -> LintM () -> WarnsAndErrs
    forall a b. (a -> b) -> a -> b
    $
      do { (CoAxiom Branched -> LintM ()) -> [CoAxiom Branched] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ CoAxiom Branched -> LintM ()
    lint_axiom [CoAxiom Branched]
    axioms
         ; let axiom_groups :: [NonEmpty (CoAxiom Branched)]
    axiom_groups = (CoAxiom Branched -> TyCon)
    -> [CoAxiom Branched] -> [NonEmpty (CoAxiom Branched)]
    forall (f :: * -> *) b a.
    (Foldable f, Eq b) =>
    (a -> b) -> f a -> [NonEmpty a]
    groupWith CoAxiom Branched -> TyCon
    forall (br :: BranchFlag). CoAxiom br -> TyCon
    coAxiomTyCon [CoAxiom Branched]
    axioms
         ; (NonEmpty (CoAxiom Branched) -> LintM ())
    -> [NonEmpty (CoAxiom Branched)] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ NonEmpty (CoAxiom Branched) -> LintM ()
    lint_axiom_group [NonEmpty (CoAxiom Branched)]
    axiom_groups }

    lint_axiom :: CoAxiom Branched -> LintM ()
    lint_axiom :: CoAxiom Branched -> LintM ()
    lint_axiom ax :: CoAxiom Branched
    ax@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
    co_ax_tc = TyCon
    tc, co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
    co_ax_branches = Branches Branched
    branches
                           , co_ax_role :: forall (br :: BranchFlag). CoAxiom br -> Role
    co_ax_role = Role
    ax_role })
      = LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (CoAxiom Branched -> LintLocInfo
    InAxiom CoAxiom Branched
    ax) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        do { (CoAxBranch -> LintM ()) -> [CoAxBranch] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (TyCon -> CoAxBranch -> LintM ()
    lint_branch TyCon
    tc) [CoAxBranch]
    branch_list
           ; LintM ()
    extra_checks }
      where
        branch_list :: [CoAxBranch]
    branch_list = Branches Branched -> [CoAxBranch]
    forall (br :: BranchFlag). Branches br -> [CoAxBranch]
    fromBranches Branches Branched
    branches

        extra_checks :: LintM ()
    extra_checks
          | TyCon -> Bool
    isNewTyCon TyCon
    tc
          = do { CoAxBranch { cab_tvs     = ax_tvs
                            , cab_eta_tvs = eta_tvs
                            , cab_cvs     = cvs
                            , cab_roles   = roles
                            , cab_lhs     = lhs_tys }
                  <- case [CoAxBranch]
    branch_list of
                   [CoAxBranch
    branch] -> CoAxBranch -> LintM CoAxBranch
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoAxBranch
    branch
                   [CoAxBranch]
    _        -> SDoc -> LintM CoAxBranch
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "multi-branch axiom with newtype")

               -- The LHS of the axiom is (N lhs_tys)
               -- We expect it to be      (N ax_tvs)
               ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)
                       (text "Newtype axiom LHS does not match newtype definition")
               ; lintL (null cvs)
                       (text "Newtype axiom binds coercion variables")
               ; lintL (null eta_tvs)  -- See Note [Eta reduction for data families]
                                       -- which is not about newtype axioms
                       (text "Newtype axiom has eta-tvs")
               ; lintL (ax_role == Representational)
                       (text "Newtype axiom role not representational")
               ; lintL (roles `equalLength` ax_tvs)
                       (text "Newtype axiom roles list is the wrong length." $$
                        text "roles:" <+> sep (map ppr roles))
               ; lintL (roles == takeList roles (tyConRoles tc))
                       (vcat [ text "Newtype axiom roles do not match newtype tycon's."
                             , text "axiom roles:" <+> sep (map ppr roles)
                             , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ])
               }

          | TyCon -> Bool
    isFamilyTyCon TyCon
    tc
          = do { if | TyCon -> Bool
    isTypeFamilyTyCon TyCon
    tc
                      -> Bool -> SDoc -> LintM ()
    lintL (Role
    ax_role Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Nominal)
                               (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "type family axiom is not nominal")

                    | TyCon -> Bool
    isDataFamilyTyCon TyCon
    tc
                      -> Bool -> SDoc -> LintM ()
    lintL (Role
    ax_role Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Representational)
                               (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "data family axiom is not representational")

                    | Bool
    otherwise
                      -> SDoc -> LintM ()
    addErrL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "A family TyCon is neither a type family nor a data family:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc)

               ; (CoAxBranch -> LintM ()) -> [CoAxBranch] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (TyCon -> CoAxBranch -> LintM ()
    lint_family_branch TyCon
    tc) [CoAxBranch]
    branch_list }

          | Bool
    otherwise
          = SDoc -> LintM ()
    addErrL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Axiom tycon is neither a newtype nor a family.")

    lint_branch :: TyCon -> CoAxBranch -> LintM ()
    lint_branch :: TyCon -> CoAxBranch -> LintM ()
    lint_branch TyCon
    ax_tc (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
    cab_tvs = [Var]
    tvs, cab_cvs :: CoAxBranch -> [Var]
    cab_cvs = [Var]
    cvs
                                  , cab_lhs :: CoAxBranch -> [LintedType]
    cab_lhs = [LintedType]
    lhs_args, cab_rhs :: CoAxBranch -> LintedType
    cab_rhs = LintedType
    rhs })
      = BindingSite -> [Var] -> ([Var] -> LintM ()) -> LintM ()
    forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
    lintBinders BindingSite
    LambdaBind ([Var]
    tvs [Var] -> [Var] -> [Var]
    forall a. [a] -> [a] -> [a]
    ++ [Var]
    cvs) (([Var] -> LintM ()) -> LintM ())
    -> ([Var] -> LintM ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \[Var]
    _ ->
        do { let lhs :: LintedType
    lhs = TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    ax_tc [LintedType]
    lhs_args
           ; lhs' <- LintedType -> LintM LintedType
    lintType LintedType
    lhs
           ; rhs' <- lintType rhs
           ; let lhs_kind = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    lhs'
                 rhs_kind = HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    rhs'
           ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $
             hang (text "Inhomogeneous axiom")
                2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$
                   text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }
             -- Type and Constraint are not Apart, so this test allows
             -- the newtype axiom for a single-method class.  Indeed the
             -- whole reason Type and Constraint are not Apart is to allow
             -- such axioms!

    -- these checks do not apply to newtype axioms
    lint_family_branch :: TyCon -> CoAxBranch -> LintM ()
    lint_family_branch :: TyCon -> CoAxBranch -> LintM ()
    lint_family_branch TyCon
    fam_tc br :: CoAxBranch
    br@(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
    cab_tvs     = [Var]
    tvs
                                             , cab_eta_tvs :: CoAxBranch -> [Var]
    cab_eta_tvs = [Var]
    eta_tvs
                                             , cab_cvs :: CoAxBranch -> [Var]
    cab_cvs     = [Var]
    cvs
                                             , cab_roles :: CoAxBranch -> [Role]
    cab_roles   = [Role]
    roles
                                             , cab_lhs :: CoAxBranch -> [LintedType]
    cab_lhs     = [LintedType]
    lhs
                                             , cab_incomps :: CoAxBranch -> [CoAxBranch]
    cab_incomps = [CoAxBranch]
    incomps })
      = do { Bool -> SDoc -> LintM ()
    lintL (TyCon -> Bool
    isDataFamilyTyCon TyCon
    fam_tc Bool -> Bool -> Bool
    || [Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    eta_tvs)
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Type family axiom has eta-tvs")
           ; Bool -> SDoc -> LintM ()
    lintL ((Var -> Bool) -> [Var] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Var -> IdSet -> Bool
    `elemVarSet` [LintedType] -> IdSet
    tyCoVarsOfTypes [LintedType]
    lhs) [Var]
    tvs)
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Quantified variable in family axiom unused in LHS")
           ; Bool -> SDoc -> LintM ()
    lintL ((LintedType -> Bool) -> [LintedType] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all LintedType -> Bool
    isTyFamFree [LintedType]
    lhs)
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Type family application on LHS of family axiom")
           ; Bool -> SDoc -> LintM ()
    lintL ((Role -> Bool) -> [Role] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Nominal) [Role]
    roles)
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-nominal role in family axiom" SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                    String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "roles:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    sep ((Role -> SDoc) -> [Role] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Role]
    roles))
           ; Bool -> SDoc -> LintM ()
    lintL ([Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    cvs)
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Coercion variables bound in family axiom")
           ; [CoAxBranch] -> (CoAxBranch -> LintM ()) -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [CoAxBranch]
    incomps ((CoAxBranch -> LintM ()) -> LintM ())
    -> (CoAxBranch -> LintM ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \ CoAxBranch
    br' ->
               Bool -> SDoc -> LintM ()
    lintL (Bool -> Bool
    not (CoAxBranch -> CoAxBranch -> Bool
    compatibleBranches CoAxBranch
    br CoAxBranch
    br')) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
               SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Incorrect incompatible branches:")
                  JoinArity
    2 ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Branch:"       SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoAxBranch -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxBranch
    br,
                           String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bogus incomp:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoAxBranch -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxBranch
    br']) }

    lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()
    lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()
    lint_axiom_group (CoAxiom Branched
    _  :| []) = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    lint_axiom_group (CoAxiom Branched
    ax :| [CoAxiom Branched]
    axs)
      = do { Bool -> SDoc -> LintM ()
    lintL (TyCon -> Bool
    isOpenFamilyTyCon TyCon
    tc)
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-open-family with multiple axioms")
           ; let all_pairs :: [(CoAxiom Branched, CoAxiom Branched)]
    all_pairs = [ (CoAxiom Branched
    ax1, CoAxiom Branched
    ax2) | CoAxiom Branched
    ax1 <- [CoAxiom Branched]
    all_axs
                                          , CoAxiom Branched
    ax2 <- [CoAxiom Branched]
    all_axs ]
           ; ((CoAxiom Branched, CoAxiom Branched) -> LintM ())
    -> [(CoAxiom Branched, CoAxiom Branched)] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()
    lint_axiom_pair TyCon
    tc) [(CoAxiom Branched, CoAxiom Branched)]
    all_pairs }
      where
        all_axs :: [CoAxiom Branched]
    all_axs = CoAxiom Branched
    ax CoAxiom Branched -> [CoAxiom Branched] -> [CoAxiom Branched]
    forall a. a -> [a] -> [a]
    : [CoAxiom Branched]
    axs
        tc :: TyCon
    tc      = CoAxiom Branched -> TyCon
    forall (br :: BranchFlag). CoAxiom br -> TyCon
    coAxiomTyCon CoAxiom Branched
    ax

    lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()
    lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()
    lint_axiom_pair TyCon
    tc (CoAxiom Branched
    ax1, CoAxiom Branched
    ax2)
      | Just br1 :: CoAxBranch
    br1@(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
    cab_tvs = [Var]
    tvs1
                             , cab_lhs :: CoAxBranch -> [LintedType]
    cab_lhs = [LintedType]
    lhs1
                             , cab_rhs :: CoAxBranch -> LintedType
    cab_rhs = LintedType
    rhs1 }) <- CoAxiom Branched -> Maybe CoAxBranch
    forall (br :: BranchFlag). CoAxiom br -> Maybe CoAxBranch
    coAxiomSingleBranch_maybe CoAxiom Branched
    ax1
      , Just br2 :: CoAxBranch
    br2@(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
    cab_tvs = [Var]
    tvs2
                             , cab_lhs :: CoAxBranch -> [LintedType]
    cab_lhs = [LintedType]
    lhs2
                             , cab_rhs :: CoAxBranch -> LintedType
    cab_rhs = LintedType
    rhs2 }) <- CoAxiom Branched -> Maybe CoAxBranch
    forall (br :: BranchFlag). CoAxiom br -> Maybe CoAxBranch
    coAxiomSingleBranch_maybe CoAxiom Branched
    ax2
      = Bool -> SDoc -> LintM ()
    lintL (CoAxBranch -> CoAxBranch -> Bool
    compatibleBranches CoAxBranch
    br1 CoAxBranch
    br2) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Axioms", CoAxiom Branched -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiom Branched
    ax1, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "and", CoAxiom Branched -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiom Branched
    ax2
                    , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "are incompatible" ]
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "tvs1 =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    pprTyVars [Var]
    tvs1
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "lhs1 =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc [LintedType]
    lhs1)
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "rhs1 =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs1
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "tvs2 =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    pprTyVars [Var]
    tvs2
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "lhs2 =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc [LintedType]
    lhs2)
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "rhs2 =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs2 ]

      | Bool
    otherwise
      = SDoc -> LintM ()
    addErrL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Open type family axiom has more than one branch: either" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
                 CoAxiom Branched -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiom Branched
    ax1 SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "or" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoAxiom Branched -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiom Branched
    ax2)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[lint-monad]{The Lint monad}
    *                                                                      *
    ************************************************************************
    -}

    -- If you edit this type, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    data LintEnv
      = LE { LintEnv -> LintFlags
    le_flags :: LintFlags       -- Linting the result of this pass
           , LintEnv -> [LintLocInfo]
    le_loc   :: [LintLocInfo]   -- Locations

           , LintEnv -> Subst
    le_subst :: Subst  -- Current TyCo substitution
                                   --    See Note [Linting type lets]
                -- /Only/ substitutes for type variables;
                --        but might clone CoVars
                -- We also use le_subst to keep track of
                -- in-scope TyVars and CoVars (but not Ids)
                -- Range of the Subst is LintedType/LintedCo

           , LintEnv -> VarEnv (Var, LintedType)
    le_ids   :: VarEnv (Id, LintedType)    -- In-scope Ids
                -- Used to check that occurrences have an enclosing binder.
                -- The Id is /pre-substitution/, used to check that
                -- the occurrence has an identical type to the binder
                -- The LintedType is used to return the type of the occurrence,
                -- without having to lint it again.

           , LintEnv -> IdSet
    le_joins :: IdSet     -- Join points in scope that are valid
                                   -- A subset of the InScopeSet in le_subst
                                   -- See Note [Join points]

           , LintEnv -> NameEnv UsageEnv
    le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the
                                               -- alias-like binders, as found in
                                               -- non-recursive lets.

           , LintEnv -> Platform
    le_platform   :: Platform         -- ^ Target platform
           , LintEnv -> DiagOpts
    le_diagOpts   :: DiagOpts         -- ^ Target platform
           }

    data LintFlags
      = LF { LintFlags -> Bool
    lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]
           , LintFlags -> Bool
    lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
           , LintFlags -> StaticPtrCheck
    lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]
           , LintFlags -> Bool
    lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]
           , LintFlags -> Bool
    lf_check_linearity :: Bool -- ^ See Note [Linting linearity]
           , LintFlags -> Bool
    lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism]
        }

    -- See Note [Checking StaticPtrs]
    data StaticPtrCheck
        = AllowAnywhere
            -- ^ Allow 'makeStatic' to occur anywhere.
        | AllowAtTopLevel
            -- ^ Allow 'makeStatic' calls at the top-level only.
        | RejectEverywhere
            -- ^ Reject any 'makeStatic' occurrence.
      deriving StaticPtrCheck -> StaticPtrCheck -> Bool
    (StaticPtrCheck -> StaticPtrCheck -> Bool)
    -> (StaticPtrCheck -> StaticPtrCheck -> Bool) -> Eq StaticPtrCheck
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: StaticPtrCheck -> StaticPtrCheck -> Bool
    == :: StaticPtrCheck -> StaticPtrCheck -> Bool
    $c/= :: StaticPtrCheck -> StaticPtrCheck -> Bool
    /= :: StaticPtrCheck -> StaticPtrCheck -> Bool
    Eq

    newtype LintM a =
       LintM' { forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM ::
                LintEnv ->
                WarnsAndErrs ->           -- Warning and error messages so far
                LResult a } -- Result and messages (if any)

    pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad
    pattern $mLintM :: forall {r} {a}.
    LintM a
    -> ((LintEnv -> WarnsAndErrs -> LResult a) -> r)
    -> ((# #) -> r)
    -> r
    $bLintM :: forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM m <- LintM' m
      where
        LintM LintEnv -> WarnsAndErrs -> LResult a
    m = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM' ((LintEnv -> WarnsAndErrs -> LResult a)
    -> LintEnv -> WarnsAndErrs -> LResult a
    forall a b. (a -> b) -> a -> b
    oneShot ((LintEnv -> WarnsAndErrs -> LResult a)
     -> LintEnv -> WarnsAndErrs -> LResult a)
    -> (LintEnv -> WarnsAndErrs -> LResult a)
    -> LintEnv
    -> WarnsAndErrs
    -> LResult a
    forall a b. (a -> b) -> a -> b
    $ \LintEnv
    env -> (WarnsAndErrs -> LResult a) -> WarnsAndErrs -> LResult a
    forall a b. (a -> b) -> a -> b
    oneShot ((WarnsAndErrs -> LResult a) -> WarnsAndErrs -> LResult a)
    -> (WarnsAndErrs -> LResult a) -> WarnsAndErrs -> LResult a
    forall a b. (a -> b) -> a -> b
    $ \WarnsAndErrs
    we -> LintEnv -> WarnsAndErrs -> LResult a
    m LintEnv
    env WarnsAndErrs
    we)
        -- LintM m = LintM' (oneShot $ oneShot m)
    {-# COMPLETE LintM #-}

    instance Functor (LintM) where
      fmap :: forall a b. (a -> b) -> LintM a -> LintM b
    fmap a -> b
    f (LintM LintEnv -> WarnsAndErrs -> LResult a
    m) = (LintEnv -> WarnsAndErrs -> LResult b) -> LintM b
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult b) -> LintM b)
    -> (LintEnv -> WarnsAndErrs -> LResult b) -> LintM b
    forall a b. (a -> b) -> a -> b
    $ \LintEnv
    e WarnsAndErrs
    w -> (a -> b) -> LResult a -> LResult b
    forall a1 a2. (a1 -> a2) -> LResult a1 -> LResult a2
    mapLResult a -> b
    f (LintEnv -> WarnsAndErrs -> LResult a
    m LintEnv
    e WarnsAndErrs
    w)

    type WarnsAndErrs = (Bag SDoc, Bag SDoc)

    -- Using a unboxed tuple here reduced allocations for a lint heavy
    -- file by ~6%. Using MaybeUB reduced them further by another ~12%.
    type LResult a = (# MaybeUB a, WarnsAndErrs #)

    pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a
    pattern $mLResult :: forall {r} {a}.
    LResult a -> (MaybeUB a -> WarnsAndErrs -> r) -> ((# #) -> r) -> r
    $bLResult :: forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult m w = (# m, w #)
    {-# COMPLETE LResult #-}

    mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2
    mapLResult :: forall a1 a2. (a1 -> a2) -> LResult a1 -> LResult a2
    mapLResult a1 -> a2
    f (LResult MaybeUB a1
    r WarnsAndErrs
    w) = MaybeUB a2 -> WarnsAndErrs -> LResult a2
    forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult ((a1 -> a2) -> MaybeUB a1 -> MaybeUB a2
    forall a b. (a -> b) -> MaybeUB a -> MaybeUB b
    fmapMaybeUB a1 -> a2
    f MaybeUB a1
    r) WarnsAndErrs
    w

    -- Just for testing.
    fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult :: forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (Just a
    x, WarnsAndErrs
    errs) = MaybeUB a -> WarnsAndErrs -> LResult a
    forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult (a -> MaybeUB a
    forall a. a -> MaybeUB a
    JustUB a
    x) WarnsAndErrs
    errs
    fromBoxedLResult (Maybe a
    Nothing,WarnsAndErrs
    errs) = MaybeUB a -> WarnsAndErrs -> LResult a
    forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult (# #) -> forall a. MaybeUB a
    forall a. MaybeUB a
    NothingUB WarnsAndErrs
    errs

    {- Note [Checking for global Ids]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Before CoreTidy, all locally-bound Ids must be LocalIds, even
    top-level ones. See Note [Exported LocalIds] and #9857.

    Note [Checking StaticPtrs]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.

    Every occurrence of the function 'makeStatic' should be moved to the
    top level by the FloatOut pass.  It's vital that we don't have nested
    'makeStatic' occurrences after CorePrep, because we populate the Static
    Pointer Table from the top-level bindings. See SimplCore Note [Grand
    plan for static forms].

    The linter checks that no occurrence is left behind, nested within an
    expression. The check is enabled only after the FloatOut, CorePrep,
    and CoreTidy passes and only if the module uses the StaticPointers
    language extension. Checking more often doesn't help since the condition
    doesn't hold until after the first FloatOut pass.

    Note [Type substitution]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    Why do we need a type substitution?  Consider
            /\(a:*). \(x:a). /\(a:*). id a x
    This is ill typed, because (renaming variables) it is really
            /\(a:*). \(x:a). /\(b:*). id b x
    Hence, when checking an application, we can't naively compare x's type
    (at its binding site) with its expected type (at a use site).  So we
    rename type binders as we go, maintaining a substitution.

    The same substitution also supports let-type, current expressed as
            (/\(a:*). body) ty
    Here we substitute 'ty' for 'a' in 'body', on the fly.

    Note [Linting type synonym applications]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When linting a type-synonym, or type-family, application
      S ty1 .. tyn
    we behave as follows (#15057, #T15664):

    * If lf_report_unsat_syns = True, and S has arity < n,
      complain about an unsaturated type synonym or type family

    * Switch off lf_report_unsat_syns, and lint ty1 .. tyn.

      Reason: catch out of scope variables or other ill-kinded gubbins,
      even if S discards that argument entirely. E.g. (#15012):
         type FakeOut a = Int
         type family TF a
         type instance TF Int = FakeOut a
      Here 'a' is out of scope; but if we expand FakeOut, we conceal
      that out-of-scope error.

      Reason for switching off lf_report_unsat_syns: with
      LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they
      are saturated when the type is expanded. Example
         type T f = f Int
         type S a = a -> a
         type Z = T S
      In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.

    * If lf_report_unsat_syns is on, expand the synonym application and
      lint the result.  Reason: want to check that synonyms are saturated
      when the type is expanded.

    Note [Linting linearity]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    Lint ignores linearity unless `-dlinear-core-lint` is set.  For why, see below.

    But first, "ignore linearity" specifically means two things. When ignoring linearity:
    * In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`
    * In `ensureSubMult`, do nothing

    But why make `-dcore-lint` ignore linearity?  Because optimisation passes are
    not (yet) guaranteed to maintain linearity.  They should do so semantically (GHC
    is careful not to duplicate computation) but it is much harder to ensure that
    the statically-checkable constraints of Linear Core are maintained. The current
    Linear Core is described in the wiki at:
    https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.

    Here are some examples of how the optimiser can break linearity checking.  Other
    examples are documented in the linear-type implementation wiki page
    [https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]

    * EXAMPLE 1: the binder swap transformation
        Consider

          data T = MkT {-# UNPACK #-} !Int

        The wrapper for MkT is

          $wMkT :: Int %1 -> T
          $wMkT n = case %1 n of
            I# n' -> MkT n'

        This introduces, in particular, a `case %1` (this is not actual Haskell or
        Core syntax), where the `%1` means that the `case` expression consumes its
        scrutinee linearly.

        Now, `case %1` interacts with the binder swap optimisation in a non-trivial
        way. Take a slightly modified version of the code for $wMkT:

          case %1 x of z {
            I# n' -> (x, n')
          }

        Binder-swap changes this to

          case %1 x of z {
            I# n' -> let x = z in (x, n')
          }

        This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly
        2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees
        two uses of n' where there should be a single one.

    * EXAMPLE 2: letrec
        Some optimisations can create a letrec which uses a variable
        linearly, e.g.

          letrec f True = f False
                 f False = x
          in f True

        uses 'x' linearly, but this is not seen by the linter, which considers,
        conservatively, that a letrec always has multiplicity Many (in particular
        that every captured free variable must have multiplicity Many). This issue
        is discussed in ticket #18694.

    * EXAMPLE 3: rewrite rules
        Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be
        treated the same by rewrite rules (see also Note [Rewrite rules ignore
        multiplicities in FunTy] in GHC.Core.Unify). Consider

          m :: Bool -> A
          m' :: (Bool -> Bool) -> A
          {- RULES "ex" forall f. m (f True) = m' f -}

          f :: Bool %1 -> A
          x = m (f True)

        The rule "ex" must match . So the linter must accept `m' f`.

    * EXAMPLE 4: eta-reduction
       Eta-expansion can change linear functions into unrestricted functions

         f :: A %1 -> B

         g :: A %Many -> B
         g = \x -> f x

       Eta-reduction undoes this and produces:

         g :: A %Many -> B
         g = f

    Historical note: In the original linear-types implementation, we had tried to
    make every optimisation pass produce code that passes `-dlinear-core-lint`. It
    had proved very difficult. We kept finding corner case after corner
    case. Furthermore, to attempt to achieve that goal we ended up restricting
    transformations when `-dlinear-core-lint` couldn't typecheck the result.

    In the future, we may be able to lint the linearity of the output of
    Core-to-Core passes (#19165). But this shouldn't be done at the expense of
    producing efficient code. Therefore we lay the following principle.

    PRINCIPLE: The type system bends to the optimisation, not the other way around.

    There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123

    Note [Linting representation-polymorphic builtins]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    As described in Note [Representation-polymorphism checking built-ins], on
    top of the two main representation-polymorphism invariants described in the
    Note [Representation polymorphism invariants], we must perform additional
    representation-polymorphism checks on builtin functions which don't have a
    binding, for example to ensure that we don't run afoul of the
    representation-polymorphism invariants when eta-expanding.

    There are two situations:

      1. Builtins which have skolem type variables which must be instantiated to
         concrete types, such as the RuntimeRep type argument r to the catch# primop.

      2. Representation-polymorphic unlifted newtypes, which must always be instantiated
         at a fixed runtime representation.

    For 1, consider for example 'coerce':

      coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b

    We store in the IdDetails of the coerce Id that the first binder, r, must always
    be instantiated to a concrete type. We thus check this in Core Lint: whenever we
    see an application of the form

      coerce @{rep1} ...

    we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp".
    Moreover, not instantiating these type variables at all is also an error, as
    we would again not be able to perform eta-expansion. (This is a bit more theoretical,
    as in user programs the typechecker will insert these type applications when
    instantiating, but it can still arise when constructing Core expressions).

    For 2, whenever we have an unlifted newtype such as

      type RR :: Type -> RuntimeRep
      type family RR a

      type F :: forall (a :: Type) -> TYPE (RR a)
      type family F a

      type N :: forall (a :: Type) -> TYPE (RR a)
      newtype N a = MkN (F a)

    and an unsaturated occurrence

      MkN @ty -- NB: no value argument!

    we check that the (instantiated) argument type has a fixed runtime representation.
    This is done in the function "checkRepPolyNewtypeApp".
    -}

    instance Applicative LintM where
          pure :: forall a. a -> LintM a
    pure a
    x = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    _ WarnsAndErrs
    errs -> MaybeUB a -> WarnsAndErrs -> LResult a
    forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult (a -> MaybeUB a
    forall a. a -> MaybeUB a
    JustUB a
    x) WarnsAndErrs
    errs
                                       --(Just x, 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

    instance Monad LintM where
      LintM a
    m >>= :: forall a b. LintM a -> (a -> LintM b) -> LintM b
    >>= a -> LintM b
    k  = (LintEnv -> WarnsAndErrs -> LResult b) -> LintM b
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs ->
                           let res :: LResult a
    res = LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m LintEnv
    env WarnsAndErrs
    errs in
                             case LResult a
    res of
                               LResult (JustUB a
    r) WarnsAndErrs
    errs' -> LintM b -> LintEnv -> WarnsAndErrs -> LResult b
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM (a -> LintM b
    k a
    r) LintEnv
    env WarnsAndErrs
    errs'
                               LResult MaybeUB a
    NothingUB WarnsAndErrs
    errs' -> MaybeUB b -> WarnsAndErrs -> LResult b
    forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult (# #) -> forall a. MaybeUB a
    forall a. MaybeUB a
    NothingUB WarnsAndErrs
    errs'
                        )
                              --  LError errs'-> LError errs')
                          --  let (res, errs') = unLintM m env errs in
                              --  Just r -> unLintM (k r) env errs'
                              --  Nothing -> (Nothing, errs'))

    instance MonadFail LintM where
        fail :: forall a. String -> LintM a
    fail String
    err = SDoc -> LintM a
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    err)

    getPlatform :: LintM Platform
    getPlatform :: LintM Platform
    getPlatform = (LintEnv -> WarnsAndErrs -> LResult Platform) -> LintM Platform
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\ LintEnv
    e WarnsAndErrs
    errs -> (MaybeUB Platform -> WarnsAndErrs -> LResult Platform
    forall a. MaybeUB a -> WarnsAndErrs -> LResult a
    LResult (Platform -> MaybeUB Platform
    forall a. a -> MaybeUB a
    JustUB (Platform -> MaybeUB Platform) -> Platform -> MaybeUB Platform
    forall a b. (a -> b) -> a -> b
    $ LintEnv -> Platform
    le_platform LintEnv
    e) WarnsAndErrs
    errs))

    data LintLocInfo
      = RhsOf Id            -- The variable bound
      | OccOf Id            -- Occurrence of id
      | LambdaBodyOf Id     -- The lambda-binder
      | RuleOf Id           -- Rules attached to a binder
      | UnfoldingOf Id      -- Unfolding of a binder
      | BodyOfLet Id        -- The let-bound variable
      | BodyOfLetRec [Id]   -- The binders of the let
      | CaseAlt CoreAlt     -- Case alternative
      | CasePat CoreAlt     -- The *pattern* of the case alternative
      | CaseTy CoreExpr     -- The type field of a case expression
                            -- with this scrutinee
      | IdTy Id             -- The type field of an Id binder
      | AnExpr CoreExpr     -- Some expression
      | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
      | TopLevelBindings
      | InType Type         -- Inside a type
      | InCo   Coercion     -- Inside a coercion
      | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom

    data LintConfig = LintConfig
      { LintConfig -> DiagOpts
    l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts
      , LintConfig -> Platform
    l_platform   :: !Platform         -- ^ Target platform
      , LintConfig -> LintFlags
    l_flags      :: !LintFlags        -- ^ Linting the result of this pass
      , LintConfig -> [Var]
    l_vars       :: ![Var]            -- ^ 'Id's that should be treated as being in scope
      }

    initL :: LintConfig
          -> LintM a            -- ^ Action to run
          -> WarnsAndErrs
    initL :: forall a. LintConfig -> LintM a -> WarnsAndErrs
    initL LintConfig
    cfg LintM a
    m
      = case LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m LintEnv
    env (Bag SDoc
    forall a. Bag a
    emptyBag, Bag SDoc
    forall a. Bag a
    emptyBag) of
          LResult (JustUB a
    _) WarnsAndErrs
    errs -> WarnsAndErrs
    errs
          LResult MaybeUB a
    NothingUB errs :: WarnsAndErrs
    errs@(Bag SDoc
    _, Bag SDoc
    e) | Bool -> Bool
    not (Bag SDoc -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Bag SDoc
    e) -> WarnsAndErrs
    errs
                                        | Bool
    otherwise -> String -> SDoc -> WarnsAndErrs
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic (String
    "Bug in Lint: a failure occurred " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                                          String
    "without reporting an error message") SDoc
    forall doc. IsOutput doc => doc
    empty
      where
        ([Var]
    tcvs, [Var]
    ids) = (Var -> Bool) -> [Var] -> ([Var], [Var])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition Var -> Bool
    isTyCoVar ([Var] -> ([Var], [Var])) -> [Var] -> ([Var], [Var])
    forall a b. (a -> b) -> a -> b
    $ LintConfig -> [Var]
    l_vars LintConfig
    cfg
        env :: LintEnv
    env = LE { le_flags :: LintFlags
    le_flags = LintConfig -> LintFlags
    l_flags LintConfig
    cfg
                 , le_subst :: Subst
    le_subst = InScopeSet -> Subst
    mkEmptySubst ([Var] -> InScopeSet
    mkInScopeSetList [Var]
    tcvs)
                 , le_ids :: VarEnv (Var, LintedType)
    le_ids   = [(Var, (Var, LintedType))] -> VarEnv (Var, LintedType)
    forall a. [(Var, a)] -> VarEnv a
    mkVarEnv [(Var
    id, (Var
    id,Var -> LintedType
    idType Var
    id)) | Var
    id <- [Var]
    ids]
                 , le_joins :: IdSet
    le_joins = IdSet
    emptyVarSet
                 , le_loc :: [LintLocInfo]
    le_loc = []
                 , le_ue_aliases :: NameEnv UsageEnv
    le_ue_aliases = NameEnv UsageEnv
    forall a. NameEnv a
    emptyNameEnv
                 , le_platform :: Platform
    le_platform = LintConfig -> Platform
    l_platform LintConfig
    cfg
                 , le_diagOpts :: DiagOpts
    le_diagOpts = LintConfig -> DiagOpts
    l_diagOpts LintConfig
    cfg
                 }

    setReportUnsat :: Bool -> LintM a -> LintM a
    -- Switch off lf_report_unsat_syns
    setReportUnsat :: forall a. Bool -> LintM a -> LintM a
    setReportUnsat Bool
    ru LintM a
    thing_inside
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
        let env' :: LintEnv
    env' = LintEnv
    env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }
        in LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    thing_inside LintEnv
    env' WarnsAndErrs
    errs

    -- See Note [Checking for representation polymorphism]
    noFixedRuntimeRepChecks :: LintM a -> LintM a
    noFixedRuntimeRepChecks :: forall a. LintM a -> LintM a
    noFixedRuntimeRepChecks LintM a
    thing_inside
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \LintEnv
    env WarnsAndErrs
    errs ->
        let env' :: LintEnv
    env' = LintEnv
    env { le_flags = (le_flags env) { lf_check_fixed_rep = False } }
        in LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    thing_inside LintEnv
    env' WarnsAndErrs
    errs

    getLintFlags :: LintM LintFlags
    getLintFlags :: LintM LintFlags
    getLintFlags = (LintEnv -> WarnsAndErrs -> LResult LintFlags) -> LintM LintFlags
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult LintFlags) -> LintM LintFlags)
    -> (LintEnv -> WarnsAndErrs -> LResult LintFlags)
    -> LintM LintFlags
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> (Maybe LintFlags, WarnsAndErrs) -> LResult LintFlags
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (LintFlags -> Maybe LintFlags
    forall a. a -> Maybe a
    Just (LintEnv -> LintFlags
    le_flags LintEnv
    env), WarnsAndErrs
    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 ()
    forall a. SDoc -> LintM a
    failWithL SDoc
    msg

    -- like checkL, but relevant to type checking
    lintL :: Bool -> SDoc -> LintM ()
    lintL :: Bool -> SDoc -> LintM ()
    lintL = Bool -> SDoc -> LintM ()
    checkL

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

    failWithL :: SDoc -> LintM a
    failWithL :: forall a. SDoc -> LintM a
    failWithL SDoc
    msg = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env (Bag SDoc
    warns,Bag SDoc
    errs) ->
                    (Maybe a, WarnsAndErrs) -> LResult a
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (Maybe a
    forall a. Maybe a
    Nothing, (Bag SDoc
    warns, Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
    addMsg Bool
    True LintEnv
    env Bag SDoc
    errs SDoc
    msg))

    addErrL :: SDoc -> LintM ()
    addErrL :: SDoc -> LintM ()
    addErrL SDoc
    msg = (LintEnv -> WarnsAndErrs -> LResult ()) -> LintM ()
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult ()) -> LintM ())
    -> (LintEnv -> WarnsAndErrs -> LResult ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env (Bag SDoc
    warns,Bag SDoc
    errs) ->
                  (Maybe (), WarnsAndErrs) -> LResult ()
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (() -> Maybe ()
    forall a. a -> Maybe a
    Just (), (Bag SDoc
    warns, Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
    addMsg Bool
    True LintEnv
    env Bag SDoc
    errs SDoc
    msg))

    addWarnL :: SDoc -> LintM ()
    addWarnL :: SDoc -> LintM ()
    addWarnL SDoc
    msg = (LintEnv -> WarnsAndErrs -> LResult ()) -> LintM ()
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult ()) -> LintM ())
    -> (LintEnv -> WarnsAndErrs -> LResult ()) -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env (Bag SDoc
    warns,Bag SDoc
    errs) ->
                  (Maybe (), WarnsAndErrs) -> LResult ()
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (() -> Maybe ()
    forall a. a -> Maybe a
    Just (), (Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
    addMsg Bool
    False LintEnv
    env Bag SDoc
    warns SDoc
    msg, Bag SDoc
    errs))

    addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc
    addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
    addMsg Bool
    is_error LintEnv
    env Bag SDoc
    msgs SDoc
    msg
      = Bool -> SDoc -> Bag SDoc -> Bag SDoc
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ([(SrcLoc, SDoc)] -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull [(SrcLoc, SDoc)]
    loc_msgs) SDoc
    msg (Bag SDoc -> Bag SDoc) -> Bag SDoc -> Bag SDoc
    forall a b. (a -> b) -> a -> b
    $
        Bag SDoc
    msgs Bag SDoc -> SDoc -> Bag SDoc
    forall a. Bag a -> a -> Bag a
    `snocBag` SDoc -> SDoc
    mk_msg SDoc
    msg
      where
       loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first
       loc_msgs :: [(SrcLoc, SDoc)]
    loc_msgs = (LintLocInfo -> (SrcLoc, SDoc))
    -> [LintLocInfo] -> [(SrcLoc, SDoc)]
    forall a b. (a -> b) -> [a] -> [b]
    map LintLocInfo -> (SrcLoc, SDoc)
    dumpLoc (LintEnv -> [LintLocInfo]
    le_loc LintEnv
    env)

       cxt_doc :: SDoc
    cxt_doc = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> [SDoc]
    forall a. [a] -> [a]
    reverse ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
    forall a b. (a -> b) -> a -> b
    $ ((SrcLoc, SDoc) -> SDoc) -> [(SrcLoc, SDoc)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (SrcLoc, SDoc) -> SDoc
    forall a b. (a, b) -> b
    snd [(SrcLoc, SDoc)]
    loc_msgs
                      , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Substitution:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Subst -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (LintEnv -> Subst
    le_subst LintEnv
    env) ]
       context :: SDoc
    context | Bool
    is_error  = SDoc
    cxt_doc
               | Bool
    otherwise = SDoc -> SDoc
    forall doc. IsOutput doc => doc -> doc
    whenPprDebug SDoc
    cxt_doc
         -- Print voluminous info for Lint errors
         -- but not for warnings

       msg_span :: SrcSpan
    msg_span = case [ SrcSpan
    span | (SrcLoc
    loc,SDoc
    _) <- [(SrcLoc, SDoc)]
    loc_msgs
                              , let span :: SrcSpan
    span = SrcLoc -> SrcSpan
    srcLocSpan SrcLoc
    loc
                              , SrcSpan -> Bool
    isGoodSrcSpan SrcSpan
    span ] of
                   []    -> SrcSpan
    noSrcSpan
                   (SrcSpan
    s:[SrcSpan]
    _) -> SrcSpan
    s
       !diag_opts :: DiagOpts
    diag_opts = LintEnv -> DiagOpts
    le_diagOpts LintEnv
    env
       mk_msg :: SDoc -> SDoc
    mk_msg SDoc
    msg = MessageClass -> SrcSpan -> SDoc -> SDoc
    mkLocMessage (DiagOpts
    -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    mkMCDiagnostic DiagOpts
    diag_opts DiagnosticReason
    WarningWithoutFlag Maybe DiagnosticCode
    forall a. Maybe a
    Nothing) SrcSpan
    msg_span
                                 (SDoc
    msg SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    context)

    addLoc :: LintLocInfo -> LintM a -> LintM a
    addLoc :: forall a. LintLocInfo -> LintM a -> LintM a
    addLoc LintLocInfo
    extra_loc LintM a
    m
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
        LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m (LintEnv
    env { le_loc = extra_loc : le_loc env }) WarnsAndErrs
    errs

    inCasePat :: LintM Bool         -- A slight hack; see the unique call site
    inCasePat :: LintM Bool
    inCasePat = (LintEnv -> WarnsAndErrs -> LResult Bool) -> LintM Bool
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult Bool) -> LintM Bool)
    -> (LintEnv -> WarnsAndErrs -> LResult Bool) -> LintM Bool
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> (Maybe Bool, WarnsAndErrs) -> LResult Bool
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just (LintEnv -> Bool
    is_case_pat LintEnv
    env), WarnsAndErrs
    errs)
      where
        is_case_pat :: LintEnv -> Bool
    is_case_pat (LE { le_loc :: LintEnv -> [LintLocInfo]
    le_loc = CasePat {} : [LintLocInfo]
    _ }) = Bool
    True
        is_case_pat LintEnv
    _other                           = Bool
    False

    addInScopeId :: Id -> LintedType -> LintM a -> LintM a
    addInScopeId :: forall a. Var -> LintedType -> LintM a -> LintM a
    addInScopeId Var
    id LintedType
    linted_ty LintM a
    m
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ env :: LintEnv
    env@(LE { le_ids :: LintEnv -> VarEnv (Var, LintedType)
    le_ids = VarEnv (Var, LintedType)
    id_set, le_joins :: LintEnv -> IdSet
    le_joins = IdSet
    join_set, le_ue_aliases :: LintEnv -> NameEnv UsageEnv
    le_ue_aliases = NameEnv UsageEnv
    aliases }) WarnsAndErrs
    errs ->
        LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m (LintEnv
    env { le_ids   = extendVarEnv id_set id (id, linted_ty)
                       , le_joins = add_joins join_set
                       , le_ue_aliases = delFromNameEnv aliases (idName id) }) WarnsAndErrs
    errs
                       -- When shadowing an alias, we need to make sure the Id is no longer
                       -- classified as such. E.g. in
                       -- let x = <e1> in case x of x { _DEFAULT -> <e2> }
                       -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.
      where
        add_joins :: IdSet -> IdSet
    add_joins IdSet
    join_set
          | Var -> Bool
    isJoinId Var
    id = IdSet -> Var -> IdSet
    extendVarSet IdSet
    join_set Var
    id -- Overwrite with new arity
          | Bool
    otherwise   = IdSet -> Var -> IdSet
    delVarSet    IdSet
    join_set Var
    id -- Remove any existing binding

    getInScopeIds :: LintM (VarEnv (Id,LintedType))
    getInScopeIds :: LintM (VarEnv (Var, LintedType))
    getInScopeIds = (LintEnv -> WarnsAndErrs -> LResult (VarEnv (Var, LintedType)))
    -> LintM (VarEnv (Var, LintedType))
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\LintEnv
    env WarnsAndErrs
    errs -> (Maybe (VarEnv (Var, LintedType)), WarnsAndErrs)
    -> LResult (VarEnv (Var, LintedType))
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (VarEnv (Var, LintedType) -> Maybe (VarEnv (Var, LintedType))
    forall a. a -> Maybe a
    Just (LintEnv -> VarEnv (Var, LintedType)
    le_ids LintEnv
    env), WarnsAndErrs
    errs))

    extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a
    extendTvSubstL :: forall a. Var -> LintedType -> LintM a -> LintM a
    extendTvSubstL Var
    tv LintedType
    ty LintM a
    m
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
        LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m (LintEnv
    env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) WarnsAndErrs
    errs

    updateSubst :: Subst -> LintM a -> LintM a
    updateSubst :: forall a. Subst -> LintM a -> LintM a
    updateSubst Subst
    subst' LintM a
    m
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m (LintEnv
    env { le_subst = subst' }) WarnsAndErrs
    errs

    markAllJoinsBad :: LintM a -> LintM a
    markAllJoinsBad :: forall a. LintM a -> LintM a
    markAllJoinsBad LintM a
    m
      = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    m (LintEnv
    env { le_joins = emptyVarSet }) WarnsAndErrs
    errs

    markAllJoinsBadIf :: Bool -> LintM a -> LintM a
    markAllJoinsBadIf :: forall a. Bool -> LintM a -> LintM a
    markAllJoinsBadIf Bool
    True  LintM a
    m = LintM a -> LintM a
    forall a. LintM a -> LintM a
    markAllJoinsBad LintM a
    m
    markAllJoinsBadIf Bool
    False LintM a
    m = LintM a
    m

    getValidJoins :: LintM IdSet
    getValidJoins :: LintM IdSet
    getValidJoins = (LintEnv -> WarnsAndErrs -> LResult IdSet) -> LintM IdSet
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (Maybe IdSet, WarnsAndErrs) -> LResult IdSet
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (IdSet -> Maybe IdSet
    forall a. a -> Maybe a
    Just (LintEnv -> IdSet
    le_joins LintEnv
    env), WarnsAndErrs
    errs))

    getSubst :: LintM Subst
    getSubst :: LintM Subst
    getSubst = (LintEnv -> WarnsAndErrs -> LResult Subst) -> LintM Subst
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (Maybe Subst, WarnsAndErrs) -> LResult Subst
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (Subst -> Maybe Subst
    forall a. a -> Maybe a
    Just (LintEnv -> Subst
    le_subst LintEnv
    env), WarnsAndErrs
    errs))

    getUEAliases :: LintM (NameEnv UsageEnv)
    getUEAliases :: LintM (NameEnv UsageEnv)
    getUEAliases = (LintEnv -> WarnsAndErrs -> LResult (NameEnv UsageEnv))
    -> LintM (NameEnv UsageEnv)
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (Maybe (NameEnv UsageEnv), WarnsAndErrs)
    -> LResult (NameEnv UsageEnv)
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (NameEnv UsageEnv -> Maybe (NameEnv UsageEnv)
    forall a. a -> Maybe a
    Just (LintEnv -> NameEnv UsageEnv
    le_ue_aliases LintEnv
    env), WarnsAndErrs
    errs))

    getInScope :: LintM InScopeSet
    getInScope :: LintM InScopeSet
    getInScope = (LintEnv -> WarnsAndErrs -> LResult InScopeSet) -> LintM InScopeSet
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (Maybe InScopeSet, WarnsAndErrs) -> LResult InScopeSet
    forall a. (Maybe a, WarnsAndErrs) -> LResult a
    fromBoxedLResult (InScopeSet -> Maybe InScopeSet
    forall a. a -> Maybe a
    Just (Subst -> InScopeSet
    getSubstInScope (Subst -> InScopeSet) -> Subst -> InScopeSet
    forall a b. (a -> b) -> a -> b
    $ LintEnv -> Subst
    le_subst LintEnv
    env), WarnsAndErrs
    errs))

    lookupIdInScope :: Id -> LintM (Id, LintedType)
    lookupIdInScope :: Var -> LintM (Var, LintedType)
    lookupIdInScope Var
    id_occ
      = do { in_scope_ids <- LintM (VarEnv (Var, LintedType))
    getInScopeIds
           ; case lookupVarEnv in_scope_ids id_occ of
               Just (Var
    id_bndr, LintedType
    linted_ty)
                 -> do { Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (Var -> Bool
    bad_global Var
    id_bndr)) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ Var -> SDoc
    global_in_scope Var
    id_bndr
                       ; (Var, LintedType) -> LintM (Var, LintedType)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var
    id_bndr, LintedType
    linted_ty) }
               Maybe (Var, LintedType)
    Nothing -> do { Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not Bool
    is_local) SDoc
    local_out_of_scope
                             ; (Var, LintedType) -> LintM (Var, LintedType)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var
    id_occ, Var -> LintedType
    idType Var
    id_occ) } }
                          -- We don't bother to lint the type
                          -- of global (i.e. imported) Ids
      where
        is_local :: Bool
    is_local = Var -> Bool
    mustHaveLocalBinding Var
    id_occ
        local_out_of_scope :: SDoc
    local_out_of_scope = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Out of scope:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    id_occ
        global_in_scope :: Var -> SDoc
    global_in_scope Var
    id_bndr = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Occurrence is GlobalId, but binding is LocalId")
                                     JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "occurrence:") JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    id_occ
                                              ,SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "binder    :") JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    id_bndr
                                              ]
        bad_global :: Var -> Bool
    bad_global Var
    id_bnd = Var -> Bool
    isGlobalId Var
    id_occ
                         Bool -> Bool -> Bool
    && Var -> Bool
    isLocalId Var
    id_bnd
                         Bool -> Bool -> Bool
    && Bool -> Bool
    not (Var -> Bool
    forall thing. NamedThing thing => thing -> Bool
    isWiredIn Var
    id_occ)
           -- 'bad_global' checks for the case where an /occurrence/ is
           -- a GlobalId, but there is an enclosing binding fora a LocalId.
           -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,
           --     but GHCi adds GlobalIds from the interactive context.  These
           --     are fine; hence the test (isLocalId id == isLocalId v)
           -- NB: when compiling Control.Exception.Base, things like absentError
           --     are defined locally, but appear in expressions as (global)
           --     wired-in Ids after worker/wrapper
           --     So we simply disable the test in this case

    lookupJoinId :: Id -> LintM JoinPointHood
    -- Look up an Id which should be a join point, valid here
    -- If so, return its arity, if not return Nothing
    lookupJoinId :: Var -> LintM JoinPointHood
    lookupJoinId Var
    id
      = do { join_set <- LintM IdSet
    getValidJoins
           ; case lookupVarSet join_set id of
                Just Var
    id' -> JoinPointHood -> LintM JoinPointHood
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> JoinPointHood
    idJoinPointHood Var
    id')
                Maybe Var
    Nothing  -> JoinPointHood -> LintM JoinPointHood
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return JoinPointHood
    NotJoinPoint }

    addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a
    addAliasUE :: forall a. Var -> UsageEnv -> LintM a -> LintM a
    addAliasUE Var
    id UsageEnv
    ue LintM a
    thing_inside = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
      let new_ue_aliases :: NameEnv UsageEnv
    new_ue_aliases =
            NameEnv UsageEnv -> Name -> UsageEnv -> NameEnv UsageEnv
    forall a. NameEnv a -> Name -> a -> NameEnv a
    extendNameEnv (LintEnv -> NameEnv UsageEnv
    le_ue_aliases LintEnv
    env) (Var -> Name
    forall a. NamedThing a => a -> Name
    getName Var
    id) UsageEnv
    ue
      in
        LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
    unLintM LintM a
    thing_inside (LintEnv
    env { le_ue_aliases = new_ue_aliases }) WarnsAndErrs
    errs

    varCallSiteUsage :: Id -> LintM UsageEnv
    varCallSiteUsage :: Var -> LintM UsageEnv
    varCallSiteUsage Var
    id =
      do m <- LintM (NameEnv UsageEnv)
    getUEAliases
         return $ case lookupNameEnv m (getName id) of
             Maybe UsageEnv
    Nothing    -> Var -> UsageEnv
    singleUsageUE Var
    id
             Just UsageEnv
    id_ue -> UsageEnv
    id_ue

    ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
    -- check ty2 is subtype of ty1 (ie, has same structure but usage
    -- annotations need only be consistent, not equal)
    -- Assumes ty1,ty2 are have already had the substitution applied
    {-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys]
    ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    ty1 LintedType
    ty2 SDoc
    msg
      = do { flags <- LintM LintFlags
    getLintFlags
           ; lintL (eq_type flags ty1 ty2) msg }

    eq_type :: LintFlags -> Type -> Type -> Bool
    -- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to
    -- be equal. See Note [Linting linearity].
    eq_type :: LintFlags -> LintedType -> LintedType -> Bool
    eq_type LintFlags
    flags LintedType
    ty1 LintedType
    ty2 | LintFlags -> Bool
    lf_check_linearity LintFlags
    flags = HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    eqType                     LintedType
    ty1 LintedType
    ty2
                          | Bool
    otherwise                = LintedType -> LintedType -> Bool
    eqTypeIgnoringMultiplicity LintedType
    ty1 LintedType
    ty2

    {- Note [INLINE ensureEqTys]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    To make Lint fast, we want to avoid allocating a thunk for <msg> in
          ensureEqTypes ty1 ty2 <msg>
    because the test almost always succeeds, and <msg> isn't needed.
    So we INLINE `ensureEqTys`.  This actually make a difference of
    1-2% when compiling programs with -dcore-lint.
    -}

    ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()
    ensureSubUsage :: Usage -> LintedType -> SDoc -> LintM ()
    ensureSubUsage Usage
    Bottom     LintedType
    _              SDoc
    _ = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    ensureSubUsage Usage
    Zero       LintedType
    described_mult SDoc
    err_msg = LintedType -> LintedType -> SDoc -> LintM ()
    ensureSubMult LintedType
    ManyTy LintedType
    described_mult SDoc
    err_msg
    ensureSubUsage (MUsage LintedType
    m) LintedType
    described_mult SDoc
    err_msg = LintedType -> LintedType -> SDoc -> LintM ()
    ensureSubMult LintedType
    m LintedType
    described_mult SDoc
    err_msg

    ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()
    ensureSubMult :: LintedType -> LintedType -> SDoc -> LintM ()
    ensureSubMult LintedType
    actual_mult LintedType
    described_mult SDoc
    err_msg = do
        flags <- LintM LintFlags
    getLintFlags
        when (lf_check_linearity flags) $
          unless (deepSubMult actual_mult described_mult) $
            addErrL err_msg
      where
        -- Check for submultiplicity using the following rules:
        -- 1. x*y <= z when x <= z and y <= z.
        --    This rule follows from the fact that x*y = sup{x,y} for any
        --    multiplicities x,y.
        -- 2. x <= y*z when x <= y or x <= z.
        --    This rule is not complete: when x = y*z, we cannot
        --    change y*z <= y*z to y*z <= y or y*z <= z.
        --    However, we eliminate products on the LHS in step 1.
        -- 3. One <= x and x <= Many for any x, as checked by 'submult'.
        -- 4. x <= x.
        -- Otherwise, we fail.
        deepSubMult :: Mult -> Mult -> Bool
        deepSubMult :: LintedType -> LintedType -> Bool
    deepSubMult LintedType
    m LintedType
    n
          | Just (LintedType
    m1, LintedType
    m2) <- LintedType -> Maybe (LintedType, LintedType)
    isMultMul LintedType
    m = LintedType -> LintedType -> Bool
    deepSubMult LintedType
    m1 LintedType
    n  Bool -> Bool -> Bool
    && LintedType -> LintedType -> Bool
    deepSubMult LintedType
    m2 LintedType
    n
          | Just (LintedType
    n1, LintedType
    n2) <- LintedType -> Maybe (LintedType, LintedType)
    isMultMul LintedType
    n = LintedType -> LintedType -> Bool
    deepSubMult LintedType
    m  LintedType
    n1 Bool -> Bool -> Bool
    || LintedType -> LintedType -> Bool
    deepSubMult LintedType
    m  LintedType
    n2
          | IsSubmult
    Submult <- LintedType
    m LintedType -> LintedType -> IsSubmult
    `submult` LintedType
    n = Bool
    True
          | Bool
    otherwise = LintedType
    m HasCallStack => LintedType -> LintedType -> Bool
    LintedType -> LintedType -> Bool
    `eqType` LintedType
    n

    lintRole :: Outputable thing
              => thing     -- where the role appeared
              -> Role      -- expected
              -> Role      -- actual
              -> LintM ()
    lintRole :: forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole thing
    co Role
    r1 Role
    r2
      = Bool -> SDoc -> LintM ()
    lintL (Role
    r1 Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    r2)
              (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Role incompatibility: expected" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Role
    r1 SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "got" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Role
    r2 SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "in" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> thing -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr thing
    co)

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Error messages}
    *                                                                      *
    ************************************************************************
    -}

    dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)

    dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
    dumpLoc (RhsOf Var
    v)
      = (Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    v, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the RHS of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    pp_binders [Var
    v])

    dumpLoc (OccOf Var
    v)
      = (Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    v, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In an occurrence of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    pp_binder Var
    v)

    dumpLoc (LambdaBodyOf Var
    b)
      = (Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    b, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the body of lambda with binder" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    pp_binder Var
    b)

    dumpLoc (RuleOf Var
    b)
      = (Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    b, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In a rule attached to" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    pp_binder Var
    b)

    dumpLoc (UnfoldingOf Var
    b)
      = (Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    b, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the unfolding of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    pp_binder Var
    b)

    dumpLoc (BodyOfLet Var
    b)
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the body of a let with binder" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    pp_binder Var
    b)

    dumpLoc (BodyOfLetRec [])
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In body of a letrec with no binders")

    dumpLoc (BodyOfLetRec bs :: [Var]
    bs@(Var
    b:[Var]
    _))
      = ( Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    b, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the body of a letrec with binders" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    pp_binders [Var]
    bs)

    dumpLoc (AnExpr CoreExpr
    e)
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the expression:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)

    dumpLoc (CaseAlt (Alt AltCon
    con [Var]
    args CoreExpr
    _))
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In a case alternative:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (AltCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AltCon
    con SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    pp_binders [Var]
    args))

    dumpLoc (CasePat (Alt AltCon
    con [Var]
    args CoreExpr
    _))
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the pattern of a case alternative:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (AltCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AltCon
    con SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [Var] -> SDoc
    pp_binders [Var]
    args))

    dumpLoc (CaseTy CoreExpr
    scrut)
      = (SrcLoc
    noSrcLoc, SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the result-type of a case with scrutinee:")
                      JoinArity
    2 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    scrut))

    dumpLoc (IdTy Var
    b)
      = (Var -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Var
    b, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the type of a binder:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    b)

    dumpLoc (ImportedUnfolding SrcLoc
    locn)
      = (SrcLoc
    locn, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In an imported unfolding")
    dumpLoc LintLocInfo
    TopLevelBindings
      = (SrcLoc
    noSrcLoc, SDoc
    forall doc. IsOutput doc => doc
    Outputable.empty)
    dumpLoc (InType LintedType
    ty)
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the type" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty))
    dumpLoc (InCo Coercion
    co)
      = (SrcLoc
    noSrcLoc, String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the coercion" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co))
    dumpLoc (InAxiom CoAxiom Branched
    ax)
      = (CoAxiom Branched -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc CoAxiom Branched
    ax, SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In the coercion axiom")
                          JoinArity
    2 (CoAxiom Branched -> SDoc
    forall (br :: BranchFlag). CoAxiom br -> SDoc
    pprCoAxiom CoAxiom Branched
    ax))

    pp_binders :: [Var] -> SDoc
    pp_binders :: [Var] -> SDoc
    pp_binders [Var]
    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 ((Var -> SDoc) -> [Var] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Var -> SDoc
    pp_binder [Var]
    bs))

    pp_binder :: Var -> SDoc
    pp_binder :: Var -> SDoc
    pp_binder Var
    b | Var -> Bool
    isId Var
    b    = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    b, SDoc
    dcolon, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    b)]
                | Bool
    otherwise = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    b, SDoc
    dcolon, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    tyVarKind Var
    b)]

    ------------------------------------------------------
    --      Messages for case expressions

    mkDefaultArgsMsg :: [Var] -> SDoc
    mkDefaultArgsMsg :: [Var] -> SDoc
    mkDefaultArgsMsg [Var]
    args
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "DEFAULT case with binders")
             JoinArity
    4 ([Var] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Var]
    args)

    mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc
    mkCaseAltMsg :: CoreExpr -> LintedType -> LintedType -> SDoc
    mkCaseAltMsg CoreExpr
    e LintedType
    ty1 LintedType
    ty2
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Type of case alternatives not the same as the annotation on case:")
             JoinArity
    4 ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Actual type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty1,
                       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Annotation on case:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty2,
                       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Alt Rhs:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e ])

    mkScrutMsg :: Id -> Type -> Type -> Subst -> SDoc
    mkScrutMsg :: Var -> LintedType -> LintedType -> Subst -> SDoc
    mkScrutMsg Var
    var LintedType
    var_ty LintedType
    scrut_ty Subst
    subst
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Result binder in case doesn't match scrutinee:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var,
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Result binder type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    var_ty,--(idType var),
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty,
         [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Current TCv subst", Subst -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Subst
    subst]]

    mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc
    mkNonDefltMsg :: CoreExpr -> SDoc
    mkNonDefltMsg CoreExpr
    e
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Case expression with DEFAULT not at the beginning") JoinArity
    4 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)
    mkNonIncreasingAltsMsg :: CoreExpr -> SDoc
    mkNonIncreasingAltsMsg CoreExpr
    e
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Case expression with badly-ordered alternatives") JoinArity
    4 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)

    nonExhaustiveAltsMsg :: CoreExpr -> SDoc
    nonExhaustiveAltsMsg :: CoreExpr -> SDoc
    nonExhaustiveAltsMsg CoreExpr
    e
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Case expression with non-exhaustive alternatives") JoinArity
    4 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)

    mkBadConMsg :: TyCon -> DataCon -> SDoc
    mkBadConMsg :: TyCon -> DataCon -> SDoc
    mkBadConMsg TyCon
    tycon DataCon
    datacon
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [
            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In a case alternative, data constructor isn't in scrutinee type:",
            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Scrutinee type constructor:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tycon,
            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Data con:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    datacon
        ]

    mkBadPatMsg :: Type -> Type -> SDoc
    mkBadPatMsg :: LintedType -> LintedType -> SDoc
    mkBadPatMsg LintedType
    con_result_ty LintedType
    scrut_ty
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [
            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In a case alternative, pattern result type doesn't match scrutinee type:",
            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Pattern result type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    con_result_ty,
            String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty
        ]

    integerScrutinisedMsg :: SDoc
    integerScrutinisedMsg :: SDoc
    integerScrutinisedMsg
      = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "In a LitAlt, the literal is lifted (probably Integer)"

    mkBadAltMsg :: Type -> CoreAlt -> SDoc
    mkBadAltMsg :: LintedType -> Alt Var -> SDoc
    mkBadAltMsg LintedType
    scrut_ty Alt Var
    alt
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Data alternative when scrutinee is not a tycon application",
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty,
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Alternative:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Alt Var -> SDoc
    forall a. OutputableBndr a => Alt a -> SDoc
    pprCoreAlt Alt Var
    alt ]

    mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc
    mkNewTyDataConAltMsg :: LintedType -> Alt Var -> SDoc
    mkNewTyDataConAltMsg LintedType
    scrut_ty Alt Var
    alt
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Data alternative for newtype datacon",
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty,
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Alternative:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Alt Var -> SDoc
    forall a. OutputableBndr a => Alt a -> SDoc
    pprCoreAlt Alt Var
    alt ]

    ------------------------------------------------------
    --      Other error messages

    mkAppMsg :: Type -> Type -> CoreExpr -> SDoc
    mkAppMsg :: LintedType -> LintedType -> CoreExpr -> SDoc
    mkAppMsg LintedType
    expected_arg_ty LintedType
    actual_arg_ty CoreExpr
    arg
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Argument value doesn't match argument type:",
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Expected arg type:") JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    expected_arg_ty),
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Actual arg type:") JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    actual_arg_ty),
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arg:") JoinArity
    4 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    arg)]

    mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc
    mkNonFunAppMsg :: LintedType -> LintedType -> CoreExpr -> SDoc
    mkNonFunAppMsg LintedType
    fun_ty LintedType
    arg_ty CoreExpr
    arg
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-function type in function position",
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Fun type:") JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    fun_ty),
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arg type:") JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty),
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arg:") JoinArity
    4 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    arg)]

    mkLetErr :: TyVar -> CoreExpr -> SDoc
    mkLetErr :: Var -> CoreExpr -> SDoc
    mkLetErr Var
    bndr CoreExpr
    rhs
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad `let' binding:",
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Variable:")
                     JoinArity
    4 (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    varType Var
    bndr)),
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Rhs:")
                     JoinArity
    4 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    rhs)]

    mkTyAppMsg :: Type -> Type -> SDoc
    mkTyAppMsg :: LintedType -> LintedType -> SDoc
    mkTyAppMsg LintedType
    ty LintedType
    arg_ty
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Illegal type application:",
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Function type:")
                     JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty)),
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Type argument:")
                     JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    arg_ty))]

    mkCoAppMsg :: Type -> Coercion -> SDoc
    mkCoAppMsg :: LintedType -> Coercion -> SDoc
    mkCoAppMsg LintedType
    fun_ty Coercion
    co
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Illegal coercion application:"
             , SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Function type:")
                  JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    fun_ty)
             , SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Coercion argument:")
                  JoinArity
    4 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Coercion -> LintedType
    coercionType Coercion
    co))]

    emptyRec :: CoreExpr -> SDoc
    emptyRec :: CoreExpr -> SDoc
    emptyRec CoreExpr
    e = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Empty Rec binding:") JoinArity
    2 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)

    mkRhsMsg :: Id -> SDoc -> Type -> SDoc
    mkRhsMsg :: Var -> SDoc -> LintedType -> SDoc
    mkRhsMsg Var
    binder SDoc
    what LintedType
    ty
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat
        [[SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "The type of this binder doesn't match the type of its" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon,
                Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder],
         [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Binder's type:", LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    binder)],
         [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Rhs type:", LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty]]

    badBndrTyMsg :: Id -> SDoc -> SDoc
    badBndrTyMsg :: Var -> SDoc -> SDoc
    badBndrTyMsg Var
    binder SDoc
    what
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "The type of this binder is" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Binder's type:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    binder) ]

    mkNonTopExportedMsg :: Id -> SDoc
    mkNonTopExportedMsg :: Var -> SDoc
    mkNonTopExportedMsg Var
    binder
      = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-top-level binder is marked as exported:", Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder]

    mkNonTopExternalNameMsg :: Id -> SDoc
    mkNonTopExternalNameMsg :: Var -> SDoc
    mkNonTopExternalNameMsg Var
    binder
      = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-top-level binder has an external name:", Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder]

    mkTopNonLitStrMsg :: Id -> SDoc
    mkTopNonLitStrMsg :: Var -> SDoc
    mkTopNonLitStrMsg Var
    binder
      = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Top-level Addr# binder has a non-literal rhs:", Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder]

    mkKindErrMsg :: TyVar -> Type -> SDoc
    mkKindErrMsg :: Var -> LintedType -> SDoc
    mkKindErrMsg Var
    tyvar LintedType
    arg_ty
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Kinds don't match in type application:",
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Type variable:")
                     JoinArity
    4 (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tyvar SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    tyVarKind Var
    tyvar)),
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arg type:")
                     JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    arg_ty))]

    mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc
    mkCastErr :: CoreExpr -> Coercion -> LintedType -> LintedType -> SDoc
    mkCastErr CoreExpr
    expr = String
    -> String -> SDoc -> Coercion -> LintedType -> LintedType -> SDoc
    mk_cast_err String
    "expression" String
    "type" (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    expr)

    mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc
    mkCastTyErr :: LintedType -> Coercion -> LintedType -> LintedType -> SDoc
    mkCastTyErr LintedType
    ty = String
    -> String -> SDoc -> Coercion -> LintedType -> LintedType -> SDoc
    mk_cast_err String
    "type" String
    "kind" (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)

    mk_cast_err :: String -- ^ What sort of casted thing this is
                          --   (\"expression\" or \"type\").
                -> String -- ^ What sort of coercion is being used
                          --   (\"type\" or \"kind\").
                -> SDoc   -- ^ The thing being casted.
                -> Coercion -> Type -> Type -> SDoc
    mk_cast_err :: String
    -> String -> SDoc -> Coercion -> LintedType -> LintedType -> SDoc
    mk_cast_err String
    thing_str String
    co_str SDoc
    pp_thing Coercion
    co LintedType
    from_ty LintedType
    thing_ty
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [SDoc
    from_msg SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "of Cast differs from" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    co_msg
                SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    enclosed_msg,
              SDoc
    from_msg SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    from_ty,
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (String -> String
    capitalise String
    co_str) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "of" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    enclosed_msg SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon
                SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    thing_ty,
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Actual" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    enclosed_msg SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    pp_thing,
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Coercion used in cast:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co
             ]
      where
        co_msg, from_msg, enclosed_msg :: SDoc
        co_msg :: SDoc
    co_msg       = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    co_str
        from_msg :: SDoc
    from_msg     = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "From-" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    co_msg
        enclosed_msg :: SDoc
    enclosed_msg = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "enclosed" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    thing_str

    mkBadTyVarMsg :: Var -> SDoc
    mkBadTyVarMsg :: Var -> SDoc
    mkBadTyVarMsg Var
    tv
      = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Non-tyvar used in TyVarTy:"
          SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tv SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    varType Var
    tv)

    mkBadJoinBindMsg :: Var -> SDoc
    mkBadJoinBindMsg :: Var -> SDoc
    mkBadJoinBindMsg Var
    var
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Bad join point binding:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join points can be bound only by a non-top-level let" ]

    mkInvalidJoinPointMsg :: Var -> Type -> SDoc
    mkInvalidJoinPointMsg :: Var -> LintedType -> SDoc
    mkInvalidJoinPointMsg Var
    var LintedType
    ty
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join point has invalid type:")
            JoinArity
    2 (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)

    mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
    mkBadJoinArityMsg :: Var -> JoinArity -> JoinArity -> CoreExpr -> SDoc
    mkBadJoinArityMsg Var
    var JoinArity
    ar JoinArity
    n CoreExpr
    rhs
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join point has too few lambdas",
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join var:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var,
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    ar,
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Number of lambdas:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (JoinArity
    ar JoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    - JoinArity
    n),
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Rhs = " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    rhs
               ]

    invalidJoinOcc :: Var -> SDoc
    invalidJoinOcc :: Var -> SDoc
    invalidJoinOcc Var
    var
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Invalid occurrence of a join variable:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "The binder is either not a join point, or not valid here" ]

    mkBadJumpMsg :: Var -> Int -> Int -> SDoc
    mkBadJumpMsg :: Var -> JoinArity -> JoinArity -> SDoc
    mkBadJumpMsg Var
    var JoinArity
    ar JoinArity
    nargs
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join point invoked with wrong number of arguments",
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join var:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var,
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    ar,
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Number of arguments:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall doc. IsLine doc => JoinArity -> doc
    int JoinArity
    nargs ]

    mkInconsistentRecMsg :: [Var] -> SDoc
    mkInconsistentRecMsg :: [Var] -> SDoc
    mkInconsistentRecMsg [Var]
    bndrs
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Recursive let binders mix values and join points",
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Binders:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep ((Var -> SDoc) -> [Var] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Var -> SDoc
    ppr_with_details [Var]
    bndrs) ]
      where
        ppr_with_details :: Var -> SDoc
    ppr_with_details Var
    bndr = Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> IdDetails -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> IdDetails
    idDetails Var
    bndr)

    mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc
    mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc
    mkJoinBndrOccMismatchMsg Var
    bndr JoinArity
    join_arity_bndr JoinArity
    join_arity_occ
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Mismatch in join point arity between binder and occurrence"
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Var:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arity at binding site:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    join_arity_bndr
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Arity at occurrence:  " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    join_arity_occ ]

    mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc
    mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc
    mkBndrOccTypeMismatchMsg Var
    bndr Var
    var LintedType
    bndr_ty LintedType
    var_ty
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Mismatch in type between binder and occurrence"
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Binder:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    bndr_ty
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Occurrence:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    var_ty
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "  Before subst:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    var) ]

    mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc
    mkBadJoinPointRuleMsg :: Var -> JoinArity -> CoreRule -> SDoc
    mkBadJoinPointRuleMsg Var
    bndr JoinArity
    join_arity CoreRule
    rule
      = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join point has rule with wrong number of arguments"
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Var:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    join_arity
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Rule:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreRule -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreRule
    rule ]

    dupVars :: [NonEmpty Var] -> SDoc
    dupVars :: [NonEmpty Var] -> SDoc
    dupVars [NonEmpty Var]
    vars
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Duplicate variables brought into scope")
           JoinArity
    2 ([[Var]] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((NonEmpty Var -> [Var]) -> [NonEmpty Var] -> [[Var]]
    forall a b. (a -> b) -> [a] -> [b]
    map NonEmpty Var -> [Var]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList [NonEmpty Var]
    vars))

    dupExtVars :: [NonEmpty Name] -> SDoc
    dupExtVars :: [NonEmpty Name] -> SDoc
    dupExtVars [NonEmpty Name]
    vars
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Duplicate top-level variables with the same qualified name")
           JoinArity
    2 ([[Name]] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((NonEmpty Name -> [Name]) -> [NonEmpty Name] -> [[Name]]
    forall a b. (a -> b) -> [a] -> [b]
    map NonEmpty Name -> [Name]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList [NonEmpty Name]
    vars))

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Annotation Linting}
    *                                                                      *
    ************************************************************************
    -}

    -- | This checks whether a pass correctly looks through debug
    -- annotations (@SourceNote@). This works a bit different from other
    -- consistency checks: We check this by running the given task twice,
    -- noting all differences between the results.
    lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    lintAnnots SDoc
    pname ModGuts -> CoreM ModGuts
    pass ModGuts
    guts = {-# SCC "lintAnnots" #-} do
      -- Run the pass as we normally would
      dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      logger <- getLogger
      when (gopt Opt_DoAnnotationLinting dflags) $
        liftIO $ Err.showPass logger "Annotation linting - first run"
      -- If appropriate re-run it without debug annotations to make sure
      -- that they made no difference.
      if gopt Opt_DoAnnotationLinting dflags
        then do
          nguts <- pass guts
          liftIO $ Err.showPass logger "Annotation linting - second run"
          nguts' <- withoutAnnots pass guts
          -- Finally compare the resulting bindings
          liftIO $ Err.showPass logger "Annotation linting - comparison"
          let binds = CoreProgram -> [(Var, CoreExpr)]
    forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds (CoreProgram -> [(Var, CoreExpr)])
    -> CoreProgram -> [(Var, CoreExpr)]
    forall a b. (a -> b) -> a -> b
    $ ModGuts -> CoreProgram
    mg_binds ModGuts
    nguts
              binds' = CoreProgram -> [(Var, CoreExpr)]
    forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds (CoreProgram -> [(Var, CoreExpr)])
    -> CoreProgram -> [(Var, CoreExpr)]
    forall a b. (a -> b) -> a -> b
    $ ModGuts -> CoreProgram
    mg_binds ModGuts
    nguts'
              (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
          when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat
            [ lint_banner "warning" pname
            , text "Core changes with annotations:"
            , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
            ]
          return nguts
        else
          pass guts

    -- | Run the given pass without annotations. This means that we both
    -- set the debugLevel setting to 0 in the environment as well as all
    -- annotations from incoming modules.
    withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    withoutAnnots ModGuts -> CoreM ModGuts
    pass ModGuts
    guts = do
      -- Remove debug flag from environment.
      -- TODO: supply tag here as well ?
      let withoutFlag :: CoreM a -> CoreM a
    withoutFlag = (DynFlags -> DynFlags) -> CoreM a -> CoreM a
    forall a. (DynFlags -> DynFlags) -> CoreM a -> CoreM a
    mapDynFlagsCoreM ((DynFlags -> DynFlags) -> CoreM a -> CoreM a)
    -> (DynFlags -> DynFlags) -> CoreM a -> CoreM a
    forall a b. (a -> b) -> a -> b
    $ \(!DynFlags
    dflags) -> DynFlags
    dflags { debugLevel = 0 }
      -- Nuke existing ticks in module.
      -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
      -- them in absence of debugLevel > 0.
      let nukeTicks :: Expr b -> Expr b
    nukeTicks = (CoreTickish -> Bool) -> Expr b -> Expr b
    forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
    stripTicksE (Bool -> Bool
    not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode)
          nukeAnnotsBind :: CoreBind -> CoreBind
          nukeAnnotsBind :: Bind Var -> Bind Var
    nukeAnnotsBind Bind Var
    bind = case Bind Var
    bind of
            Rec [(Var, CoreExpr)]
    bs     -> [(Var, CoreExpr)] -> Bind Var
    forall b. [(b, Expr b)] -> Bind b
    Rec ([(Var, CoreExpr)] -> Bind Var) -> [(Var, CoreExpr)] -> Bind Var
    forall a b. (a -> b) -> a -> b
    $ ((Var, CoreExpr) -> (Var, CoreExpr))
    -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Var
    b,CoreExpr
    e) -> (Var
    b, CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b
    nukeTicks CoreExpr
    e)) [(Var, CoreExpr)]
    bs
            NonRec Var
    b CoreExpr
    e -> Var -> CoreExpr -> Bind Var
    forall b. b -> Expr b -> Bind b
    NonRec Var
    b (CoreExpr -> Bind Var) -> CoreExpr -> Bind Var
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b
    nukeTicks CoreExpr
    e
          nukeAnnotsMod :: ModGuts -> ModGuts
    nukeAnnotsMod mg :: ModGuts
    mg@ModGuts{mg_binds :: ModGuts -> CoreProgram
    mg_binds=CoreProgram
    binds}
            = ModGuts
    mg{mg_binds = map nukeAnnotsBind binds}
      -- Perform pass with all changes applied. Drop the simple count so it doesn't
      -- effect the total also
      CoreM ModGuts -> CoreM ModGuts
    forall a. CoreM a -> CoreM a
    dropSimplCount (CoreM ModGuts -> CoreM ModGuts) -> CoreM ModGuts -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ CoreM ModGuts -> CoreM ModGuts
    forall a. CoreM a -> CoreM a
    withoutFlag (CoreM ModGuts -> CoreM ModGuts) -> CoreM ModGuts -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ ModGuts -> CoreM ModGuts
    pass (ModGuts -> ModGuts
    nukeAnnotsMod ModGuts
    guts)