    {-# LANGUAGE DeriveFunctor       #-}
    {-# LANGUAGE MultiWayIf          #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    {-
    (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 (
        lintCoreBindings, lintUnfolding,
        lintPassResult, lintInteractiveExpr, lintExpr,
        lintAnnots, lintAxioms,

        interactiveInScope,

        -- ** Debug output
        endPass, endPassIO,
        displayLintResults, dumpPassResult
     ) where

    import GHC.Prelude

    import GHC.Driver.Session
    import GHC.Driver.Ppr
    import GHC.Driver.Env
    import GHC.Driver.Config.Diagnostic

    import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )
    import GHC.Unit.Module.ModGuts
    import GHC.Runtime.Context

    import GHC.Core
    import GHC.Core.FVs
    import GHC.Core.Utils
    import GHC.Core.Stats ( coreBindsStats )
    import GHC.Core.Opt.Monad
    import GHC.Core.DataCon
    import GHC.Core.Ppr
    import GHC.Core.Coercion
    import GHC.Core.Type as Type
    import GHC.Core.Multiplicity
    import GHC.Core.UsageEnv
    import GHC.Core.TyCo.Rep   -- checks validity of types/coercions
    import GHC.Core.TyCo.Subst
    import GHC.Core.TyCo.FVs
    import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars )
    import GHC.Core.TyCon as TyCon
    import GHC.Core.Coercion.Axiom
    import GHC.Core.Unify
    import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts )
    import GHC.Core.Coercion.Opt ( checkAxInstCo )
    import GHC.Core.Opt.Arity    ( typeArity )

    import GHC.Types.Literal
    import GHC.Types.Var as Var
    import GHC.Types.Var.Env
    import GHC.Types.Var.Set
    import GHC.Types.Unique.Set( nonDetEltsUniqSet )
    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.RepType
    import GHC.Types.Basic
    import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )
    import GHC.Types.TypeEnv

    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.Trace
    import GHC.Utils.Error
    import qualified GHC.Utils.Error as Err
    import GHC.Utils.Logger

    import Control.Monad
    import Data.Foldable      ( toList )
    import Data.List.NonEmpty ( NonEmpty(..), groupWith )
    import Data.List          ( partition )
    import Data.Maybe
    import GHC.Data.Pair
    import qualified GHC.LanguageExtensions as LangExt

    {-
    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]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    As described in Note [Representation of function types], all saturated
    applications of funTyCon are represented with the FunTy constructor. 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 substittion 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).

    ************************************************************************
    *                                                                      *
                     Beginning and ending passes
    *                                                                      *
    ************************************************************************

    These functions are not CoreM monad stuff, but they probably ought to
    be, and it makes a convenient place for them.  They print out stuff
    before and after core passes, and do Core Lint when necessary.
    -}

    endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
    endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
    endPass CoreToDo
    pass CoreProgram
    binds [CoreRule]
    rules
      = do { HscEnv
    hsc_env <- CoreM HscEnv
    getHscEnv
           ; PrintUnqualified
    print_unqual <- CoreM PrintUnqualified
    getPrintUnqualified
           ; IO () -> CoreM ()
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ HscEnv
    -> PrintUnqualified
    -> CoreToDo
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    endPassIO HscEnv
    hsc_env PrintUnqualified
    print_unqual CoreToDo
    pass CoreProgram
    binds [CoreRule]
    rules }

    endPassIO :: HscEnv -> PrintUnqualified
              -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
    -- Used by the IO-is CorePrep too
    endPassIO :: HscEnv
    -> PrintUnqualified
    -> CoreToDo
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    endPassIO HscEnv
    hsc_env PrintUnqualified
    print_unqual CoreToDo
    pass CoreProgram
    binds [CoreRule]
    rules
      = do { Logger
    -> Bool
    -> PrintUnqualified
    -> Maybe DumpFlag
    -> String
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dumpPassResult Logger
    logger Bool
    dump_core_sizes PrintUnqualified
    print_unqual Maybe DumpFlag
    mb_flag
                            (DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags (CoreToDo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)) (CoreToDo -> SDoc
    pprPassDetails CoreToDo
    pass) CoreProgram
    binds [CoreRule]
    rules
           ; HscEnv -> CoreToDo -> CoreProgram -> IO ()
    lintPassResult HscEnv
    hsc_env CoreToDo
    pass CoreProgram
    binds }
      where
        dump_core_sizes :: Bool
    dump_core_sizes = Bool -> Bool
    not (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_SuppressCoreSizes DynFlags
    dflags)
        logger :: Logger
    logger  = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env
        dflags :: DynFlags
    dflags  = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        mb_flag :: Maybe DumpFlag
    mb_flag = case CoreToDo -> Maybe DumpFlag
    coreDumpFlag CoreToDo
    pass 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?
                   -> PrintUnqualified
                   -> 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
    -> PrintUnqualified
    -> Maybe DumpFlag
    -> String
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dumpPassResult Logger
    logger Bool
    dump_core_sizes PrintUnqualified
    unqual 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 (PrintUnqualified -> PprStyle
    mkDumpStyle PrintUnqualified
    unqual) 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
    sep [String -> SDoc
    text String
    "Result size of" SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    hdr, JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (SDoc
    equals SDoc -> SDoc -> SDoc
    <+> CoreStats -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CoreProgram -> CoreStats
    coreBindsStats CoreProgram
    binds))]

        dump_doc :: SDoc
    dump_doc  = [SDoc] -> SDoc
    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
    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
    vcat [ SDoc
    blankLine
                        , String -> SDoc
    text String
    "------ Local rules for imported ids --------"
                        , [CoreRule] -> SDoc
    pprRules [CoreRule]
    rules ]

    coreDumpFlag :: CoreToDo -> Maybe DumpFlag
    coreDumpFlag :: CoreToDo -> Maybe DumpFlag
    coreDumpFlag (CoreDoSimplify {})      = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_verbose_core2core
    coreDumpFlag (CoreDoPluginPass {})    = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_verbose_core2core
    coreDumpFlag CoreToDo
    CoreDoFloatInwards       = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_verbose_core2core
    coreDumpFlag (CoreDoFloatOutwards {}) = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_verbose_core2core
    coreDumpFlag CoreToDo
    CoreLiberateCase         = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_verbose_core2core
    coreDumpFlag CoreToDo
    CoreDoStaticArgs         = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_verbose_core2core
    coreDumpFlag CoreToDo
    CoreDoCallArity          = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_call_arity
    coreDumpFlag CoreToDo
    CoreDoExitify            = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_exitify
    coreDumpFlag CoreToDo
    CoreDoDemand             = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_stranal
    coreDumpFlag CoreToDo
    CoreDoCpr                = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_cpranal
    coreDumpFlag CoreToDo
    CoreDoWorkerWrapper      = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_worker_wrapper
    coreDumpFlag CoreToDo
    CoreDoSpecialising       = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_spec
    coreDumpFlag CoreToDo
    CoreDoSpecConstr         = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_spec
    coreDumpFlag CoreToDo
    CoreCSE                  = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_cse
    coreDumpFlag CoreToDo
    CoreDesugar              = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_ds_preopt
    coreDumpFlag CoreToDo
    CoreDesugarOpt           = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_ds
    coreDumpFlag CoreToDo
    CoreTidy                 = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_simpl
    coreDumpFlag CoreToDo
    CorePrep                 = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_prep
    coreDumpFlag CoreToDo
    CoreOccurAnal            = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_occur_anal

    coreDumpFlag CoreToDo
    CoreAddCallerCcs         = Maybe DumpFlag
    forall a. Maybe a
    Nothing
    coreDumpFlag CoreToDo
    CoreAddLateCcs           = Maybe DumpFlag
    forall a. Maybe a
    Nothing
    coreDumpFlag CoreToDo
    CoreDoPrintCore          = Maybe DumpFlag
    forall a. Maybe a
    Nothing
    coreDumpFlag (CoreDoRuleCheck {})     = Maybe DumpFlag
    forall a. Maybe a
    Nothing
    coreDumpFlag CoreToDo
    CoreDoNothing            = Maybe DumpFlag
    forall a. Maybe a
    Nothing
    coreDumpFlag (CoreDoPasses {})        = Maybe DumpFlag
    forall a. Maybe a
    Nothing

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

    lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
    lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
    lintPassResult HscEnv
    hsc_env CoreToDo
    pass CoreProgram
    binds
      | Bool -> Bool
    not (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoCoreLinting DynFlags
    dflags)
      = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      | Bool
    otherwise
      = do { let warns_and_errs :: WarnsAndErrs
    warns_and_errs = DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
    lintCoreBindings DynFlags
    dflags CoreToDo
    pass (InteractiveContext -> [Var]
    interactiveInScope (InteractiveContext -> [Var]) -> InteractiveContext -> [Var]
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> InteractiveContext
    hsc_IC HscEnv
    hsc_env) CoreProgram
    binds
           ; Logger -> String -> IO ()
    Err.showPass Logger
    logger (String
    "Core Linted result of " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ DynFlags -> CoreToDo -> String
    forall a. Outputable a => DynFlags -> a -> String
    showPpr DynFlags
    dflags CoreToDo
    pass)
           ; Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
    displayLintResults Logger
    logger (CoreToDo -> Bool
    showLintWarnings CoreToDo
    pass) (CoreToDo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
                                (CoreProgram -> SDoc
    forall b. OutputableBndr b => [Bind b] -> SDoc
    pprCoreBindings CoreProgram
    binds) WarnsAndErrs
    warns_and_errs }
      where
        dflags :: DynFlags
    dflags = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        logger :: Logger
    logger = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env

    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.MCDump SrcSpan
    noSrcSpan
               (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle
               ([SDoc] -> SDoc
    vcat [ String -> SDoc -> SDoc
    lint_banner String
    "errors" SDoc
    pp_what, Bag SDoc -> SDoc
    Err.pprMessageBag Bag SDoc
    errs
                     , String -> SDoc
    text String
    "*** Offending Program ***"
                     , SDoc
    pp_pgm
                     , String -> SDoc
    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
      -- If the Core linter encounters an error, output to stderr instead of
      -- stdout (#13342)
      = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    Err.MCInfo SrcSpan
    noSrcSpan
          (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
    $$ Bag SDoc -> SDoc
    Err.pprMessageBag ((SDoc -> SDoc) -> Bag SDoc -> Bag SDoc
    forall a b. (a -> b) -> Bag a -> Bag b
    mapBag (SDoc -> SDoc -> SDoc
    $$ 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
    text String
    "*** Core Lint"      SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    string
                              SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    ": in result of" SDoc -> SDoc -> SDoc
    <+> SDoc
    pass
                              SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "***"

    showLintWarnings :: CoreToDo -> Bool
    -- Disable Lint warnings on the first simplifier pass, because
    -- there may be some INLINE knots still tied, which is tiresomely noisy
    showLintWarnings :: CoreToDo -> Bool
    showLintWarnings (CoreDoSimplify JoinArity
    _ (SimplMode { sm_phase :: SimplMode -> CompilerPhase
    sm_phase = CompilerPhase
    InitialPhase })) = Bool
    False
    showLintWarnings CoreToDo
    _ = Bool
    True

    lintInteractiveExpr :: SDoc -- ^ The source of the linted expression
                        -> HscEnv -> CoreExpr -> IO ()
    lintInteractiveExpr :: SDoc -> HscEnv -> CoreExpr -> IO ()
    lintInteractiveExpr SDoc
    what HscEnv
    hsc_env CoreExpr
    expr
      | Bool -> Bool
    not (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoCoreLinting DynFlags
    dflags)
      = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      | Just Bag SDoc
    err <- DynFlags -> [Var] -> CoreExpr -> Maybe (Bag SDoc)
    lintExpr DynFlags
    dflags (InteractiveContext -> [Var]
    interactiveInScope (InteractiveContext -> [Var]) -> InteractiveContext -> [Var]
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> InteractiveContext
    hsc_IC HscEnv
    hsc_env) CoreExpr
    expr
      = Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
    displayLintResults Logger
    logger Bool
    False SDoc
    what (CoreExpr -> SDoc
    forall b. OutputableBndr b => Expr b -> SDoc
    pprCoreExpr CoreExpr
    expr) (Bag SDoc
    forall a. Bag a
    emptyBag, Bag SDoc
    err)
      | Bool
    otherwise
      = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      where
        dflags :: DynFlags
    dflags = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        logger :: Logger
    logger = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env

    interactiveInScope :: InteractiveContext -> [Var]
    -- In GHCi we may lint expressions, or bindings arising from 'deriving'
    -- clauses, that mention variables bound in the interactive context.
    -- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context).
    -- So we have to tell Lint about them, lest it reports them as out of scope.
    --
    -- We do this by find local-named things that may appear free in interactive
    -- context.  This function is pretty revolting and quite possibly not quite right.
    -- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
    -- so this is a (cheap) no-op.
    --
    -- See #8215 for an example
    interactiveInScope :: InteractiveContext -> [Var]
    interactiveInScope InteractiveContext
    ictxt
      = [Var]
    tyvars [Var] -> [Var] -> [Var]
    forall a. [a] -> [a] -> [a]
    ++ [Var]
    ids
      where
        -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr
        (InstEnv
    cls_insts, [FamInst]
    _fam_insts) = InteractiveContext -> (InstEnv, [FamInst])
    ic_instances InteractiveContext
    ictxt
        te1 :: TypeEnv
    te1    = [TyThing] -> TypeEnv
    mkTypeEnvWithImplicits (InteractiveContext -> [TyThing]
    ic_tythings InteractiveContext
    ictxt)
        te :: TypeEnv
    te     = TypeEnv -> [Var] -> TypeEnv
    extendTypeEnvWithIds TypeEnv
    te1 ((ClsInst -> Var) -> [ClsInst] -> [Var]
    forall a b. (a -> b) -> [a] -> [b]
    map ClsInst -> Var
    instanceDFunId ([ClsInst] -> [Var]) -> [ClsInst] -> [Var]
    forall a b. (a -> b) -> a -> b
    $ InstEnv -> [ClsInst]
    instEnvElts InstEnv
    cls_insts)
        ids :: [Var]
    ids    = TypeEnv -> [Var]
    typeEnvIds TypeEnv
    te
        tyvars :: [Var]
    tyvars = [LintedType] -> [Var]
    tyCoVarsOfTypesList ([LintedType] -> [Var]) -> [LintedType] -> [Var]
    forall a b. (a -> b) -> a -> b
    $ (Var -> LintedType) -> [Var] -> [LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map Var -> LintedType
    idType [Var]
    ids
                  -- Why the type variables?  How can the top level envt have free tyvars?
                  -- I think it's because of the GHCi debugger, which can bind variables
                  --   f :: [t] -> [t]
                  -- where t is a RuntimeUnk (see TcType)

    -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
    lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
    --   Returns (warnings, errors)
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
    lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
    lintCoreBindings DynFlags
    dflags CoreToDo
    pass [Var]
    local_in_scope CoreProgram
    binds
      = DynFlags
    -> LintFlags -> [Var] -> LintM ((), [UsageEnv]) -> WarnsAndErrs
    forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
    initL DynFlags
    dflags LintFlags
    flags [Var]
    local_in_scope (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

        flags :: LintFlags
    flags = (DynFlags -> LintFlags
    defaultLintFlags DynFlags
    dflags)
                   { lf_check_global_ids :: Bool
    lf_check_global_ids = Bool
    check_globals
                   , lf_check_inline_loop_breakers :: Bool
    lf_check_inline_loop_breakers = Bool
    check_lbs
                   , lf_check_static_ptrs :: StaticPtrCheck
    lf_check_static_ptrs = StaticPtrCheck
    check_static_ptrs
                   , lf_check_linearity :: Bool
    lf_check_linearity = Bool
    check_linearity
                   , lf_check_fixed_rep :: Bool
    lf_check_fixed_rep = Bool
    check_fixed_rep }

        -- In the output of the desugarer, before optimisation,
        -- we have eta-expanded data constructors with representation-polymorphic
        -- bindings; so we switch off the representation-polymorphism checks.
        -- The very simple optimiser will beta-reduce them away.
        -- See Note [Checking for representation-polymorphic built-ins]
        -- in GHC.HsToCore.Expr.
        check_fixed_rep :: Bool
    check_fixed_rep = case CoreToDo
    pass of
                            CoreToDo
    CoreDesugar -> Bool
    False
                            CoreToDo
    _           -> Bool
    True

        -- See Note [Checking for global Ids]
        check_globals :: Bool
    check_globals = case CoreToDo
    pass of
                          CoreToDo
    CoreTidy -> Bool
    False
                          CoreToDo
    CorePrep -> Bool
    False
                          CoreToDo
    _        -> Bool
    True

        -- See Note [Checking for INLINE loop breakers]
        check_lbs :: Bool
    check_lbs = case CoreToDo
    pass of
                          CoreToDo
    CoreDesugar    -> Bool
    False
                          CoreToDo
    CoreDesugarOpt -> Bool
    False
                          CoreToDo
    _              -> Bool
    True

        -- See Note [Checking StaticPtrs]
        check_static_ptrs :: StaticPtrCheck
    check_static_ptrs | Bool -> Bool
    not (Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.StaticPointers DynFlags
    dflags) = StaticPtrCheck
    AllowAnywhere
                          | Bool
    otherwise = case CoreToDo
    pass of
                              CoreDoFloatOutwards FloatOutSwitches
    _ -> StaticPtrCheck
    AllowAtTopLevel
                              CoreToDo
    CoreTidy              -> StaticPtrCheck
    RejectEverywhere
                              CoreToDo
    CorePrep              -> StaticPtrCheck
    AllowAtTopLevel
                              CoreToDo
    _                     -> StaticPtrCheck
    AllowAnywhere

        -- See Note [Linting linearity]
        check_linearity :: Bool
    check_linearity = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoLinearCoreLinting DynFlags
    dflags Bool -> Bool -> Bool
    || (
                            case CoreToDo
    pass of
                              CoreToDo
    CoreDesugar -> Bool
    True
                              CoreToDo
    _ -> Bool
    False)

        ([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

        -- dups_ext 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 -> Name -> Ordering) -> [Name] -> ([Name], [NonEmpty Name])
    forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
    removeDups Name -> Name -> Ordering
    ord_ext ((Var -> Name) -> [Var] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Var -> Name
    Var.varName [Var]
    binders))
        ord_ext :: Name -> Name -> Ordering
    ord_ext Name
    n1 Name
    n2 | Just Module
    m1 <- Name -> Maybe Module
    nameModule_maybe Name
    n1
                      , Just Module
    m2 <- Name -> Maybe Module
    nameModule_maybe Name
    n2
                      = (Module, OccName) -> (Module, OccName) -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (Module
    m1, Name -> OccName
    nameOccName Name
    n1) (Module
    m2, Name -> OccName
    nameOccName Name
    n2)
                      | Bool
    otherwise = Ordering
    LT

    {-
    ************************************************************************
    *                                                                      *
    \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
                  -> DynFlags
                  -> SrcLoc
                  -> VarSet           -- ^ Treat these as in scope
                  -> CoreExpr
                  -> Maybe (Bag SDoc) -- Nothing => OK

    lintUnfolding :: Bool -> DynFlags -> SrcLoc -> IdSet -> CoreExpr -> Maybe (Bag SDoc)
    lintUnfolding Bool
    is_compulsory DynFlags
    dflags SrcLoc
    locn IdSet
    var_set 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
        vars :: [Var]
    vars = IdSet -> [Var]
    forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet IdSet
    var_set
        (Bag SDoc
    _warns, Bag SDoc
    errs) = DynFlags
    -> LintFlags
    -> [Var]
    -> LintM (LintedType, UsageEnv)
    -> WarnsAndErrs
    forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
    initL DynFlags
    dflags (DynFlags -> LintFlags
    defaultLintFlags DynFlags
    dflags) [Var]
    vars (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 :: DynFlags
             -> [Var]               -- Treat these as in scope
             -> CoreExpr
             -> Maybe (Bag SDoc)  -- Nothing => OK

    lintExpr :: DynFlags -> [Var] -> CoreExpr -> Maybe (Bag SDoc)
    lintExpr DynFlags
    dflags [Var]
    vars 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) = DynFlags
    -> LintFlags
    -> [Var]
    -> LintM (LintedType, UsageEnv)
    -> WarnsAndErrs
    forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
    initL DynFlags
    dflags (DynFlags -> LintFlags
    defaultLintFlags DynFlags
    dflags) [Var]
    vars 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 { [UsageEnv]
    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
    a <- [Var] -> LintM a
    thing_inside [Var]
    bndrs'
           ; (a, [UsageEnv]) -> LintM (a, [UsageEnv])
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    a, [UsageEnv]
    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 { (LintedType
    rhs_ty, UsageEnv
    ue) <- Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr' CoreExpr
    rhs         -- Check the rhs
               ; TopLevelFlag
    -> RecFlag -> Var -> CoreExpr -> LintedType -> LintM ()
    lintLetBind TopLevelFlag
    top_lvl RecFlag
    Recursive Var
    bndr' CoreExpr
    rhs LintedType
    rhs_ty
               ; UsageEnv -> LintM UsageEnv
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UsageEnv
    ue }

    lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody :: [Var] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody [Var]
    bndrs CoreExpr
    body
      = do { (LintedType
    body_ty, UsageEnv
    body_ue) <- LintLocInfo
    -> LintM (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc ([Var] -> LintLocInfo
    BodyOfLetRec [Var]
    bndrs) (CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    body)
           ; (Var -> LintM ()) -> [Var] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (LintedType -> Var -> LintM ()
    lintJoinBndrType LintedType
    body_ty) [Var]
    bndrs
           ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    body_ty, UsageEnv
    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
    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/app invariant
            -- See Note [Core let/app 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
    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 LintedType -> LintedType -> Bool
    `eqType` LintedType
    addrPrimTy)
                     Bool -> Bool -> Bool
    || CoreExpr -> Bool
    exprIsTickedString CoreExpr
    rhs)
               (Var -> SDoc
    mkTopNonLitStrMsg Var
    binder)

           ; LintFlags
    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 Var -> Maybe JoinArity
    isJoinId_maybe Var
    binder of
                Maybe JoinArity
    Nothing    -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just JoinArity
    arity ->  Bool -> SDoc -> LintM ()
    checkL (JoinArity -> LintedType -> Bool
    isValidJoinPointType JoinArity
    arity LintedType
    binder_ty)
                                      (Var -> LintedType -> SDoc
    mkInvalidJoinPointMsg Var
    binder LintedType
    binder_ty)

           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LintFlags -> Bool
    lf_check_inline_loop_breakers LintFlags
    flags
                   Bool -> Bool -> Bool
    && Unfolding -> Bool
    isStableUnfolding (Var -> Unfolding
    realIdUnfolding Var
    binder)
                   Bool -> Bool -> Bool
    && OccInfo -> Bool
    isStrongLoopBreaker (Var -> OccInfo
    idOccInfo Var
    binder)
                   Bool -> Bool -> Bool
    && InlinePragma -> Bool
    isInlinePragma (Var -> InlinePragma
    idInlinePragma Var
    binder))
                  (SDoc -> LintM ()
    addWarnL (String -> SDoc
    text String
    "INLINE binder is (non-rule) loop breaker:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    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 [exprArity invariant]
           -- and Note [Trimming arity]
           ; Bool -> SDoc -> LintM ()
    checkL (LintedType -> [OneShotInfo]
    typeArity (Var -> LintedType
    idType Var
    binder) [OneShotInfo] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthAtLeast` Var -> JoinArity
    idArity Var
    binder)
               (String -> SDoc
    text String
    "idArity" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> JoinArity
    idArity Var
    binder) SDoc -> SDoc -> SDoc
    <+>
               String -> SDoc
    text String
    "exceeds typeArity" SDoc -> SDoc -> SDoc
    <+>
               JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ([OneShotInfo] -> JoinArity
    forall a. [a] -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length (LintedType -> [OneShotInfo]
    typeArity (Var -> LintedType
    idType Var
    binder))) SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+>
               Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder)

           ; case DmdSig -> ([Demand], Divergence)
    splitDmdSig (Var -> DmdSig
    idDmdSig Var
    binder) of
               ([Demand]
    demands, Divergence
    result_info) | Divergence -> Bool
    isDeadEndDiv Divergence
    result_info ->
                 Bool -> SDoc -> LintM ()
    checkL ([Demand]
    demands [Demand] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthAtLeast` Var -> JoinArity
    idArity Var
    binder)
                   (String -> SDoc
    text String
    "idArity" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> JoinArity
    idArity Var
    binder) SDoc -> SDoc -> SDoc
    <+>
                   String -> SDoc
    text String
    "exceeds arity imposed by the strictness signature" SDoc -> SDoc -> SDoc
    <+>
                   DmdSig -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> DmdSig
    idDmdSig Var
    binder) SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+>
                   Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder)
               ([Demand], Divergence)
    _ -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

           ; LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    RuleOf Var
    binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ (CoreRule -> LintM ()) -> [CoreRule] -> LintM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Var -> LintedType -> CoreRule -> LintM ()
    lintCoreRule Var
    binder LintedType
    binder_ty) (Var -> [CoreRule]
    idCoreRules Var
    binder)

           ; LintLocInfo -> LintM () -> LintM ()
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    UnfoldingOf Var
    binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             Var -> LintedType -> Unfolding -> LintM ()
    lintIdUnfolding Var
    binder LintedType
    binder_ty (Var -> Unfolding
    idUnfolding Var
    binder)
           ; () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    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
        | Just JoinArity
    arity <- Var -> Maybe JoinArity
    isJoinId_maybe 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 (LintedType, UsageEnv)
    fun_ty_ue <- CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    fun
                (LintedType, UsageEnv)
    -> [CoreExpr] -> LintM (LintedType, UsageEnv)
    lintCoreArgs (LintedType, UsageEnv)
    fun_ty_ue [LintedType -> CoreExpr
    forall b. LintedType -> Expr b
    Type LintedType
    t, CoreExpr
    info, CoreExpr
    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 { LintedType
    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)
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    bndr_ty LintedType
    ty (Var -> SDoc -> LintedType -> SDoc
    mkRhsMsg Var
    bndr (String -> SDoc
    text String
    "unfolding") LintedType
    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.

    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)

    ************************************************************************
    *                                                                      *
    \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 { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let (Pair LintedType
    from_ty LintedType
    to_ty, Role
    role) = Coercion -> (Pair LintedType, Role)
    coercionKindRole Coercion
    co'
           ; LintedType -> SDoc -> LintM ()
    checkValueType LintedType
    to_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             String -> SDoc
    text String
    "target of cast" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co')
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co' Role
    Representational Role
    role
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    from_ty LintedType
    expr_ty (CoreExpr -> Coercion -> LintedType -> LintedType -> SDoc
    mkCastErr CoreExpr
    expr Coercion
    co' LintedType
    from_ty LintedType
    expr_ty)
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LintedType
    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 :: (LintedType, UsageEnv)
    var_pair@(LintedType
    var_ty, UsageEnv
    _) <- Var -> JoinArity -> LintM (LintedType, UsageEnv)
    lintIdOcc Var
    var JoinArity
    0
          CoreExpr -> [CoreExpr] -> LintedType -> LintM ()
    checkCanEtaExpand (Var -> CoreExpr
    forall b. Var -> Expr b
    Var Var
    var) [] LintedType
    var_ty
          (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType, UsageEnv)
    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 (LintedType
    expr_ty, UsageEnv
    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
    expr
           LintedType
    to_ty <- CoreExpr -> LintedType -> Coercion -> LintM LintedType
    lintCastExpr CoreExpr
    expr LintedType
    expr_ty Coercion
    co
           (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    to_ty, UsageEnv
    ue)

    lintCoreExpr (Tick CoreTickish
    tickish CoreExpr
    expr)
      = do case CoreTickish
    tickish of
             Breakpoint XBreakpoint 'TickishPassCore
    _ JoinArity
    _ [XTickishId 'TickishPassCore]
    ids -> [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  { LintedType
    ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
            ; Var
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyBndr Var
    tv              ((Var -> LintM (LintedType, UsageEnv))
     -> LintM (LintedType, UsageEnv))
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ \ 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
    BodyOfLetRec [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
             (LintedType
    rhs_ty, UsageEnv
    let_ue) <- Var -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintRhs Var
    bndr CoreExpr
    rhs

              -- See Note [Multiplicity of let binders] in Var
             -- Now lint the binder
           ; BindingSite
    -> Var
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintBinder BindingSite
    LetBind Var
    bndr ((Var -> LintM (LintedType, UsageEnv))
     -> LintM (LintedType, UsageEnv))
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ \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 ([Var] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody [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
            ; ((LintedType
    body_type, UsageEnv
    body_ue), [UsageEnv]
    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' ->
                [Var] -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintLetBody [Var]
    bndrs' CoreExpr
    body
            ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    body_type, UsageEnv
    body_ue  UsageEnv -> UsageEnv -> UsageEnv
    `addUE` LintedType -> UsageEnv -> UsageEnv
    scaleUE LintedType
    Many ((UsageEnv -> UsageEnv -> UsageEnv) -> [UsageEnv] -> UsageEnv
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 UsageEnv -> UsageEnv -> UsageEnv
    addUE [UsageEnv]
    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 { (LintedType, UsageEnv)
    fun_pair1 <- (LintedType, UsageEnv) -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreArg (Var -> LintedType
    idType Var
    fun, UsageEnv
    zeroUE) CoreExpr
    ty_arg1
           ; (LintedType
    fun_ty2, UsageEnv
    ue2) <- (LintedType, UsageEnv) -> CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreArg (LintedType, UsageEnv)
    fun_pair1       CoreExpr
    ty_arg2
             -- See Note [Linting of runRW#]
           ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
                 lintRunRWCont :: CoreExpr -> 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?
           ; (LintedType
    arg3_ty, UsageEnv
    ue3) <- CoreExpr -> LintM (LintedType, UsageEnv)
    lintRunRWCont CoreExpr
    arg3
           ; (LintedType, UsageEnv)
    app_ty <- CoreExpr
    -> LintedType
    -> LintedType
    -> UsageEnv
    -> UsageEnv
    -> LintM (LintedType, UsageEnv)
    lintValApp CoreExpr
    arg3 LintedType
    fun_ty2 LintedType
    arg3_ty UsageEnv
    ue2 UsageEnv
    ue3
           ; (LintedType, UsageEnv)
    -> [CoreExpr] -> LintM (LintedType, UsageEnv)
    lintCoreArgs (LintedType, UsageEnv)
    app_ty [CoreExpr]
    rest }

      | Bool
    otherwise
      = do { (LintedType, UsageEnv)
    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 :: (LintedType, UsageEnv)
    app_pair@(LintedType
    app_ty, UsageEnv
    _) <- (LintedType, UsageEnv)
    -> [CoreExpr] -> LintM (LintedType, UsageEnv)
    lintCoreArgs (LintedType, UsageEnv)
    fun_pair [CoreExpr]
    args
           ; CoreExpr -> [CoreExpr] -> LintedType -> LintM ()
    checkCanEtaExpand CoreExpr
    fun [CoreExpr]
    args LintedType
    app_ty
           ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType, UsageEnv)
    app_pair}
      where
        (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
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable 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.

    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
    text String
    "Type found as expression" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)

    lintCoreExpr (Coercion Coercion
    co)
      = do { Coercion
    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
           ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> LintedType
    coercionType Coercion
    co', UsageEnv
    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
    text String
    "Non term variable" SDoc -> SDoc -> SDoc
    <+> 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
            ; (Var
    bndr, LintedType
    linted_bndr_ty) <- Var -> LintM (Var, LintedType)
    lookupIdInScope Var
    var
            ; let occ_ty :: LintedType
    occ_ty  = Var -> LintedType
    idType Var
    var
                  bndr_ty :: LintedType
    bndr_ty = Var -> LintedType
    idType Var
    bndr
            ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    occ_ty LintedType
    bndr_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
              Var -> Var -> LintedType -> LintedType -> SDoc
    mkBndrOccTypeMismatchMsg Var
    bndr Var
    var LintedType
    bndr_ty LintedType
    occ_ty

              -- Check for a nested occurrence of the StaticPtr constructor.
              -- See Note [Checking StaticPtrs].
            ; LintFlags
    lf <- LintM LintFlags
    getLintFlags
            ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (JoinArity
    nargs JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    /= JoinArity
    0 Bool -> Bool -> Bool
    && LintFlags -> StaticPtrCheck
    lf_check_static_ptrs LintFlags
    lf StaticPtrCheck -> StaticPtrCheck -> Bool
    forall a. Eq a => a -> a -> Bool
    /= StaticPtrCheck
    AllowAnywhere) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                Bool -> SDoc -> LintM ()
    checkL (Var -> Name
    idName Var
    var Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Name
    makeStaticName) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                  String -> SDoc
    text String
    "Found makeStatic nested in an expression"

            ; Var -> LintM ()
    checkDeadIdOcc Var
    var
            ; Var -> JoinArity -> LintM ()
    checkJoinOcc Var
    var JoinArity
    nargs

            ; UsageEnv
    usage <- Var -> LintM UsageEnv
    varCallSiteUsage Var
    var

            ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    linted_bndr_ty, UsageEnv
    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 { (LintedType
    body_ty, UsageEnv
    ue) <- LintM (LintedType, UsageEnv)
    lintBody
           ; UsageEnv
    ue' <- UsageEnv -> Var -> LintM UsageEnv
    checkLinearity UsageEnv
    ue Var
    var'
           ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> LintedType -> LintedType
    mkLamType Var
    var' LintedType
    body_ty, UsageEnv
    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 { Bool
    in_case <- LintM Bool
    inCasePat
           ; Bool -> SDoc -> LintM ()
    checkL Bool
    in_case
                    (String -> SDoc
    text String
    "Occurrence of a dead Id" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    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
      | Just JoinArity
    arity <- Var -> Maybe JoinArity
    isJoinId_maybe Var
    bndr
      , let bndr_ty :: LintedType
    bndr_ty = Var -> LintedType
    idType Var
    bndr
      , ([TyCoBinder]
    bndrs, LintedType
    res) <- LintedType -> ([TyCoBinder], LintedType)
    splitPiTys LintedType
    bndr_ty
      = Bool -> SDoc -> LintM ()
    checkL ([TyCoBinder] -> JoinArity
    forall a. [a] -> JoinArity
    forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [TyCoBinder]
    bndrs JoinArity -> JoinArity -> Bool
    forall a. Ord a => a -> a -> Bool
    >= JoinArity
    arity
                Bool -> Bool -> Bool
    && LintedType
    body_ty LintedType -> LintedType -> Bool
    `eqType` [TyCoBinder] -> LintedType -> LintedType
    mkPiTys (JoinArity -> [TyCoBinder] -> [TyCoBinder]
    forall a. JoinArity -> [a] -> [a]
    drop JoinArity
    arity [TyCoBinder]
    bndrs) LintedType
    res) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Join point returns different type than body")
           JoinArity
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Join bndr:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    bndr)
                   , String -> SDoc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    arity
                   , String -> SDoc
    text String
    "Body type:" SDoc -> SDoc -> SDoc
    <+> 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
      | Just JoinArity
    join_arity_occ <- Var -> Maybe JoinArity
    isJoinId_maybe Var
    var
      = do { Maybe JoinArity
    mb_join_arity_bndr <- Var -> LintM (Maybe JoinArity)
    lookupJoinId Var
    var
           ; case Maybe JoinArity
    mb_join_arity_bndr of {
               Maybe JoinArity
    Nothing -> -- Binder is not a join point
                          do { IdSet
    join_set <- LintM IdSet
    getValidJoins
                             ; SDoc -> LintM ()
    addErrL (String -> SDoc
    text String
    "join set " SDoc -> SDoc -> SDoc
    <+> IdSet -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr IdSet
    join_set SDoc -> SDoc -> SDoc
    $$
                                        Var -> SDoc
    invalidJoinOcc Var
    var) } ;

               Just 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 ()

    -- | This function checks that we are able to perform eta expansion for
    -- functions with no binding, in order to satisfy invariant I3
    -- from Note [Representation polymorphism invariants] in GHC.Core.
    checkCanEtaExpand :: 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 ()
    checkCanEtaExpand :: CoreExpr -> [CoreExpr] -> LintedType -> LintM ()
    checkCanEtaExpand (Var Var
    fun_id) [CoreExpr]
    args LintedType
    app_ty
      | Var -> Bool
    hasNoBinding Var
    fun_id
      = Bool -> SDoc -> LintM ()
    checkL ([LintedType] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [LintedType]
    bad_arg_tys) SDoc
    err_msg
        where
          arity :: Arity
          arity :: JoinArity
    arity = Var -> JoinArity
    idArity Var
    fun_id

          nb_val_args :: Int
          nb_val_args :: JoinArity
    nb_val_args = (CoreExpr -> Bool) -> [CoreExpr] -> JoinArity
    forall a. (a -> Bool) -> [a] -> JoinArity
    count CoreExpr -> Bool
    forall b. Expr b -> Bool
    isValArg [CoreExpr]
    args

          -- Check the remaining argument types, past the
          -- given arguments and up to the arity of the 'Id'.
          -- Returns the types that couldn't be determined to have
          -- a fixed RuntimeRep.
          check_args :: [Type] -> [Type]
          check_args :: [LintedType] -> [LintedType]
    check_args = JoinArity -> [LintedType] -> [LintedType]
    go (JoinArity
    nb_val_args JoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    + JoinArity
    1)
            where
              go :: Int    -- index of the argument (starting from 1)
                 -> [Type] -- arguments
                 -> [Type] -- value argument types that could not be
                           -- determined to have a fixed runtime representation
              go :: JoinArity -> [LintedType] -> [LintedType]
    go JoinArity
    i [LintedType]
    _
                | JoinArity
    i JoinArity -> JoinArity -> Bool
    forall a. Ord a => a -> a -> Bool
    > JoinArity
    arity
                = []
              go JoinArity
    _ []
                -- The Arity of an Id should never exceed the number of value arguments
                -- that can be read off from the Id's type.
                -- See Note [Arity and function types] in GHC.Types.Id.Info.
                = String -> SDoc -> [LintedType]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "checkCanEtaExpand: arity larger than number of value arguments apparent in type"
                    (SDoc -> [LintedType]) -> SDoc -> [LintedType]
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
                      [ String -> SDoc
    text String
    "fun_id =" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    fun_id
                      , String -> SDoc
    text String
    "arity =" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    arity
                      , String -> SDoc
    text String
    "app_ty =" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    app_ty
                      , String -> SDoc
    text String
    "args = " SDoc -> SDoc -> SDoc
    <+> [CoreExpr] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CoreExpr]
    args
                      , String -> SDoc
    text String
    "nb_val_args =" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    nb_val_args ]
              go JoinArity
    i (LintedType
    ty : [LintedType]
    bndrs)
                | LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    ty
                = JoinArity -> [LintedType] -> [LintedType]
    go (JoinArity
    iJoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    +JoinArity
    1) [LintedType]
    bndrs
                | Bool
    otherwise
                = LintedType
    ty LintedType -> [LintedType] -> [LintedType]
    forall a. a -> [a] -> [a]
    : JoinArity -> [LintedType] -> [LintedType]
    go (JoinArity
    iJoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    +JoinArity
    1) [LintedType]
    bndrs

          bad_arg_tys :: [Type]
          bad_arg_tys :: [LintedType]
    bad_arg_tys = [LintedType] -> [LintedType]
    check_args ([LintedType] -> [LintedType])
    -> ([(LintedType, AnonArgFlag)] -> [LintedType])
    -> [(LintedType, AnonArgFlag)]
    -> [LintedType]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((LintedType, AnonArgFlag) -> LintedType)
    -> [(LintedType, AnonArgFlag)] -> [LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map (LintedType, AnonArgFlag) -> LintedType
    forall a b. (a, b) -> a
    fst ([(LintedType, AnonArgFlag)] -> [LintedType])
    -> [(LintedType, AnonArgFlag)] -> [LintedType]
    forall a b. (a -> b) -> a -> b
    $ LintedType -> [(LintedType, AnonArgFlag)]
    getRuntimeArgTys LintedType
    app_ty
            -- We use 'getRuntimeArgTys' to find all the argument types,
            -- including those hidden under newtypes. For example,
            -- if `FunNT a b` is a newtype around `a -> b`, then
            -- when checking
            --
            -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c
            --
            -- we should check that the instantiations of BOTH `a` AND `b`
            -- have a fixed runtime representation.

          err_msg :: SDoc
          err_msg :: SDoc
    err_msg
            = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Cannot eta expand" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    fun_id)
                   , String -> SDoc
    text String
    "The following type" SDoc -> SDoc -> SDoc
    <> [LintedType] -> SDoc
    forall a. [a] -> SDoc
    plural [LintedType]
    bad_arg_tys
                     SDoc -> SDoc -> SDoc
    <+> [LintedType] -> SDoc
    forall a. [a] -> SDoc
    doOrDoes [LintedType]
    bad_arg_tys SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "not have a fixed runtime representation:"
                   , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ (LintedType -> SDoc) -> [LintedType] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map LintedType -> SDoc
    ppr_ty_ki [LintedType]
    bad_arg_tys ]

          ppr_ty_ki :: Type -> SDoc
          ppr_ty_ki :: LintedType -> SDoc
    ppr_ty_ki LintedType
    ty = SDoc
    bullet SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty)
    checkCanEtaExpand CoreExpr
    _ [CoreExpr]
    _ LintedType
    _
      = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    -- 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 Usage -> LintedType -> SDoc -> LintM ()
    ensureSubUsage Usage
    lhs LintedType
    mult (LintedType -> SDoc
    err_msg LintedType
    mult)
                        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
    body_ue Var
    lam_var
        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
      where
        lhs :: Usage
    lhs = UsageEnv -> Var -> Usage
    forall n. NamedThing n => UsageEnv -> n -> Usage
    lookupUE UsageEnv
    body_ue Var
    lam_var
        err_msg :: LintedType -> SDoc
    err_msg LintedType
    mult = String -> SDoc
    text String
    "Linearity failure in lambda:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    lam_var
                    SDoc -> SDoc -> SDoc
    $$ Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    lhs SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "⊈" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    mult

    {-
    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.
    -}

    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)
    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
    text String
    "Unnecessary coercion-to-type injection:"
                      SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty)
           ; LintedType
    arg_ty' <- LintedType -> LintM LintedType
    lintType LintedType
    arg_ty
           ; LintedType
    res <- LintedType -> LintedType -> LintM LintedType
    lintTyApp LintedType
    fun_ty LintedType
    arg_ty'
           ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    res, UsageEnv
    ue) }

    lintCoreArg (LintedType
    fun_ty, UsageEnv
    fun_ue) CoreExpr
    arg
      = do { (LintedType
    arg_ty, UsageEnv
    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
           ; LintFlags
    flags <- LintM LintFlags
    getLintFlags

           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LintFlags -> Bool
    lf_check_fixed_rep LintFlags
    flags) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             -- Only check that 'arg_ty' has a fixed RuntimeRep
             -- if 'lf_check_fixed_rep' is on.
             do { Bool -> SDoc -> LintM ()
    checkL (LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    arg_ty)
                         (String -> SDoc
    text String
    "Argument does not have a fixed runtime representation"
                          SDoc -> SDoc -> SDoc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    arg SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon
                          SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    arg_ty)))

                ; Bool -> SDoc -> LintM ()
    checkL (LintedType -> Bool
    mightBeLiftedType LintedType
    arg_ty Bool -> Bool -> Bool
    || CoreExpr -> Bool
    exprOkForSpeculation CoreExpr
    arg)
                         (CoreExpr -> SDoc
    mkLetAppMsg CoreExpr
    arg) }

           ; CoreExpr
    -> LintedType
    -> LintedType
    -> UsageEnv
    -> UsageEnv
    -> LintM (LintedType, UsageEnv)
    lintValApp CoreExpr
    arg LintedType
    fun_ty LintedType
    arg_ty UsageEnv
    fun_ue UsageEnv
    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 { LintedType
    con_ty' <- LintedType -> LintedType -> LintM LintedType
    lintTyApp LintedType
    con_ty (Var -> LintedType
    mkTyVarTy Var
    bndr)
           ; UsageEnv
    -> Var
    -> LintedType
    -> LintedType
    -> [(LintedType, Var)]
    -> LintM UsageEnv
    lintAltBinders UsageEnv
    rhs_ue Var
    case_bndr LintedType
    scrut_ty LintedType
    con_ty'  [(LintedType, Var)]
    bndrs }
      | Bool
    otherwise
      = do { (LintedType
    con_ty', UsageEnv
    _) <- 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.
           ; UsageEnv
    rhs_ue' <- UsageEnv -> Var -> LintedType -> Var -> LintM UsageEnv
    checkCaseLinearity UsageEnv
    rhs_ue Var
    case_bndr LintedType
    var_w Var
    bndr
           ; UsageEnv
    -> Var
    -> LintedType
    -> LintedType
    -> [(LintedType, Var)]
    -> LintM UsageEnv
    lintAltBinders UsageEnv
    rhs_ue' Var
    case_bndr LintedType
    scrut_ty LintedType
    con_ty' [(LintedType, Var)]
    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
    text String
    "Linearity failure in variable:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr
                    SDoc -> SDoc -> SDoc
    $$ Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    lhs SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "⊈" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs
                    SDoc -> SDoc -> SDoc
    $$ String -> SDoc
    text String
    "Computed by:"
                    SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "LHS:" SDoc -> SDoc -> SDoc
    <+> SDoc
    lhs_formula
                    SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "RHS:" SDoc -> SDoc -> SDoc
    <+> SDoc
    rhs_formula)
        lhs_formula :: SDoc
    lhs_formula = Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    bndr_usage SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "+"
                                     SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (Usage -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Usage
    case_bndr_usage SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "*" SDoc -> SDoc -> SDoc
    <+> 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
    <+> String -> SDoc
    text String
    "*" SDoc -> SDoc -> SDoc
    <+> 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)
    splitForAllTyCoVar_maybe LintedType
    fun_ty
      = do  { Var -> LintedType -> LintM ()
    lintTyKind Var
    tv LintedType
    arg_ty
            ; InScopeSet
    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
            ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InScopeSet -> [Var] -> [LintedType] -> LintedType -> LintedType
    substTyWithInScope InScopeSet
    in_scope [Var
    tv] [LintedType
    arg_ty] LintedType
    body_ty) }

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

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

    -- | @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 (LintedType
    w, LintedType
    arg_ty', LintedType
    res_ty') <- LintedType -> Maybe (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 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
    $$ (String -> SDoc
    text String
    "Linted Arg kind:" SDoc -> SDoc -> SDoc
    <+> 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 = (() :: Constraint) => 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
         ; (LintedType
    scrut_ty, UsageEnv
    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 :: LintedType
    scrut_mult = Var -> LintedType
    varMult Var
    var

         ; LintedType
    alt_ty <- LintLocInfo -> LintM LintedType -> LintM LintedType
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (CoreExpr -> LintLocInfo
    CaseTy CoreExpr
    scrut) (LintM LintedType -> LintM LintedType)
    -> LintM LintedType -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $
                     LintedType -> LintM LintedType
    lintValueType LintedType
    alt_ty
         ; LintedType
    var_ty <- LintLocInfo -> LintM LintedType -> LintM LintedType
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    IdTy Var
    var) (LintM LintedType -> LintM LintedType)
    -> LintM LintedType -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $
                     LintedType -> LintM LintedType
    lintValueType (Var -> LintedType
    idType Var
    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 b -> Bool
    isLitPat (Alt (LitAlt Literal
    _) [b]
    _  Expr b
    _) = Bool
    True
               isLitPat Alt b
    _                     = Bool
    False
         ; Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ LintedType -> Bool
    isFloatingPrimTy LintedType
    scrut_ty Bool -> Bool -> Bool
    && (Alt Var -> Bool) -> [Alt Var] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Alt Var -> Bool
    forall {b}. Alt b -> Bool
    isLitPat [Alt Var]
    alts)
             (String -> SDoc
    text String
    "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."
              SDoc -> SDoc -> SDoc
    $$ String -> SDoc
    text String
    "scrut" SDoc -> SDoc -> SDoc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    scrut)

         ; case LintedType -> Maybe TyCon
    tyConAppTyCon_maybe (Var -> LintedType
    idType Var
    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
    <+> 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

         ; TCvSubst
    subst <- LintM TCvSubst
    getTCvSubst
         ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    var_ty LintedType
    scrut_ty (Var -> LintedType -> LintedType -> TCvSubst -> SDoc
    mkScrutMsg Var
    var LintedType
    var_ty LintedType
    scrut_ty TCvSubst
    subst)
           -- See GHC.Core Note [Case expression invariants] item (7)

         ; BindingSite
    -> Var
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
    lintBinder BindingSite
    CaseBind Var
    var ((Var -> LintM (LintedType, UsageEnv))
     -> LintM (LintedType, UsageEnv))
    -> (Var -> LintM (LintedType, UsageEnv))
    -> LintM (LintedType, UsageEnv)
    forall a b. (a -> b) -> a -> b
    $ \Var
    _ ->
           do { -- Check the alternatives
              ; [UsageEnv]
    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 :: UsageEnv
    case_ue = (LintedType -> UsageEnv -> UsageEnv
    scaleUE LintedType
    scrut_mult UsageEnv
    scrut_ue) UsageEnv -> UsageEnv -> UsageEnv
    `addUE` [UsageEnv] -> UsageEnv
    supUEs [UsageEnv]
    alt_ues
              ; CoreExpr -> LintedType -> [Alt Var] -> LintM ()
    checkCaseAlts CoreExpr
    e LintedType
    scrut_ty [Alt Var]
    alts
              ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType
    alt_ty, UsageEnv
    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 { (LintedType
    actual_ty, UsageEnv
    ue) <- CoreExpr -> LintM (LintedType, UsageEnv)
    lintCoreExpr CoreExpr
    expr
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    actual_ty LintedType
    ann_ty (CoreExpr -> LintedType -> LintedType -> SDoc
    mkCaseAltMsg CoreExpr
    expr LintedType
    actual_ty LintedType
    ann_ty)
           ; UsageEnv -> LintM UsageEnv
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UsageEnv
    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
    _ LintedType
    _ LintedType
    _ 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)
         ; CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    rhs LintedType
    alt_ty }

    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)
           ; CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    rhs LintedType
    alt_ty }
      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) <- (() :: Constraint) => 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
        {   -- First instantiate the universally quantified
            -- type variables of the data constructor
            -- We've already check
          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)
        ; let { con_payload_ty :: LintedType
    con_payload_ty = (() :: Constraint) => LintedType -> [LintedType] -> LintedType
    LintedType -> [LintedType] -> LintedType
    piResultTys (DataCon -> LintedType
    dataConRepType DataCon
    con) [LintedType]
    tycon_arg_tys
              ; binderMult :: TyCoBinder -> LintedType
    binderMult (Named TyCoVarBinder
    _)   = LintedType
    Many
              ; binderMult (Anon AnonArgFlag
    _ Scaled LintedType
    st) = Scaled LintedType -> LintedType
    forall a. Scaled a -> LintedType
    scaledMult Scaled LintedType
    st
              -- See Note [Validating multiplicities in a case]
              ; multiplicities :: [LintedType]
    multiplicities = (TyCoBinder -> LintedType) -> [TyCoBinder] -> [LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map TyCoBinder -> LintedType
    binderMult ([TyCoBinder] -> [LintedType]) -> [TyCoBinder] -> [LintedType]
    forall a b. (a -> b) -> a -> b
    $ ([TyCoBinder], LintedType) -> [TyCoBinder]
    forall a b. (a, b) -> a
    fst (([TyCoBinder], LintedType) -> [TyCoBinder])
    -> ([TyCoBinder], LintedType) -> [TyCoBinder]
    forall a b. (a -> b) -> a -> b
    $ LintedType -> ([TyCoBinder], 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
          {
            UsageEnv
    rhs_ue <- CoreExpr -> LintedType -> LintM UsageEnv
    lintAltExpr CoreExpr
    rhs LintedType
    alt_ty
          ; UsageEnv
    rhs_ue' <- LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Alt Var -> LintLocInfo
    CasePat Alt Var
    alt) (UsageEnv
    -> Var
    -> LintedType
    -> LintedType
    -> [(LintedType, Var)]
    -> LintM UsageEnv
    lintAltBinders UsageEnv
    rhs_ue Var
    case_bndr LintedType
    scrut_ty LintedType
    con_payload_ty (String -> [LintedType] -> [Var] -> [(LintedType, Var)]
    forall a b. String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "lintCoreAlt" [LintedType]
    multiplicities  [Var]
    args'))
          ; 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
    rhs_ue' Var
    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
    text String
    "Multiplicity of variable does not agree with its context"
                    SDoc -> SDoc -> SDoc
    $$ SDoc
    doc
                    SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    actual_usage
                    SDoc -> SDoc -> SDoc
    $$ String -> SDoc
    text String
    "Annotation:" SDoc -> SDoc -> SDoc
    <+> 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

    -- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a
    -- lintCoBndr = 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 { TCvSubst
    subst <- LintM TCvSubst
    getTCvSubst
           ; LintedType
    kind' <- LintedType -> LintM LintedType
    lintType (Var -> LintedType
    varType Var
    tcv)
           ; let tcv' :: Var
    tcv' = InScopeSet -> Var -> Var
    uniqAway (TCvSubst -> InScopeSet
    getTCvInScope TCvSubst
    subst) (Var -> Var) -> Var -> Var
    forall a b. (a -> b) -> a -> b
    $
                        Var -> LintedType -> Var
    setVarType Var
    tcv LintedType
    kind'
                 subst' :: TCvSubst
    subst' = TCvSubst -> Var -> Var -> TCvSubst
    extendTCvSubstWithClone TCvSubst
    subst Var
    tcv Var
    tcv'
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Var -> Bool
    isCoVar Var
    tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             Bool -> SDoc -> LintM ()
    lintL (LintedType -> Bool
    isCoVarType LintedType
    kind')
                   (String -> SDoc
    text String
    "CoVar with non-coercion type:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    pprTyVar Var
    tcv)
           ; TCvSubst -> LintM a -> LintM a
    forall a. TCvSubst -> LintM a -> LintM a
    updateTCvSubst TCvSubst
    subst' (Var -> LintM a
    thing_inside Var
    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 { LintFlags
    flags <- LintM LintFlags
    getLintFlags
           ; Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not (LintFlags -> Bool
    lf_check_global_ids LintFlags
    flags) Bool -> Bool -> Bool
    || Var -> Bool
    isLocalId Var
    id)
                    (String -> SDoc
    text String
    "Non-local Id binder" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    id)
                    -- See Note [Checking for global Ids]

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

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

              -- See Note [Representation polymorphism invariants] in GHC.Core
           ; Bool -> SDoc -> LintM ()
    lintL (Var -> Bool
    isJoinId Var
    id Bool -> Bool -> Bool
    || Bool -> Bool
    not (LintFlags -> Bool
    lf_check_fixed_rep LintFlags
    flags)
                    Bool -> Bool -> Bool
    || LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    id_ty) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             String -> SDoc
    text String
    "Binder does not have a fixed runtime representation:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    id SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+>
                SDoc -> SDoc
    parens (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    id_ty SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    id_ty))

           -- Check that a join-id is a not-top-level let-binding
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Var -> Bool
    isJoinId Var
    id) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             Bool -> SDoc -> LintM ()
    checkL (Bool -> Bool
    not Bool
    is_top_lvl Bool -> Bool -> Bool
    && Bool
    is_let_bind) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             Var -> SDoc
    mkBadJoinBindMsg Var
    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
           ; Bool -> SDoc -> LintM ()
    lintL (Bool -> Bool
    not (LintedType -> Bool
    isCoVarType LintedType
    id_ty))
                   (String -> SDoc
    text String
    "Non-CoVar has coercion type" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    id SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    id_ty)

           ; LintedType
    linted_ty <- LintLocInfo -> LintM LintedType -> LintM LintedType
    forall a. LintLocInfo -> LintM a -> LintM a
    addLoc (Var -> LintLocInfo
    IdTy Var
    id) (LintedType -> LintM LintedType
    lintValueType LintedType
    id_ty)

           ; Var -> LintedType -> LintM a -> LintM a
    forall a. Var -> LintedType -> LintM a -> LintM a
    addInScopeId Var
    id LintedType
    linted_ty (LintM a -> LintM a) -> LintM a -> LintM a
    forall a b. (a -> b) -> a -> b
    $
             Var -> LintM a
    thing_inside (Var -> LintedType -> Var
    setIdType Var
    id LintedType
    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  { LintedType
    ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
            ; let sk :: LintedType
    sk = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty'
            ; Bool -> SDoc -> LintM ()
    lintL (LintedType -> Bool
    classifiesTypeWithValues LintedType
    sk) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Ill-kinded type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)
                 JoinArity
    2 (String -> SDoc
    text String
    "has kind:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    sk)
            ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LintedType
    ty' }

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

    -------------------
    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 { TCvSubst
    subst <- LintM TCvSubst
    getTCvSubst
           ; case TCvSubst -> Var -> Maybe LintedType
    lookupTyVar TCvSubst
    subst Var
    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 | Var
    tv Var -> TCvSubst -> Bool
    `isInScope` TCvSubst
    subst
                       -> LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> LintedType
    TyVarTy Var
    tv)
                       | Bool
    otherwise
                       -> SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM LintedType) -> SDoc -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $
                          SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "The type variable" SDoc -> SDoc -> SDoc
    <+> BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    tv)
                             JoinArity
    2 (String -> SDoc
    text String
    "is out of scope")
         }

    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
    text String
    "TyConApp to the left of AppTy:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty
      | Bool
    otherwise
      = do { LintedType
    t1' <- LintedType -> LintM LintedType
    lintType LintedType
    t1
           ; LintedType
    t2' <- LintedType -> LintM LintedType
    lintType LintedType
    t2
           ; LintedType -> LintedType -> [LintedType] -> LintM ()
    lint_ty_app LintedType
    ty ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t1') [LintedType
    t2']
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType -> LintedType -> LintedType
    AppTy LintedType
    t1' LintedType
    t2') }

    lintType ty :: LintedType
    ty@(TyConApp TyCon
    tc [LintedType]
    tys)
      | TyCon -> Bool
    isTypeSynonymTyCon TyCon
    tc Bool -> Bool -> Bool
    || TyCon -> Bool
    isTypeFamilyTyCon TyCon
    tc
      = do { Bool
    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
           ; Bool -> LintedType -> TyCon -> [LintedType] -> LintM LintedType
    lintTySynFamApp Bool
    report_unsat LintedType
    ty TyCon
    tc [LintedType]
    tys }

      | TyCon -> Bool
    isFunTyCon TyCon
    tc
      , [LintedType]
    tys [LintedType] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthIs` JoinArity
    5
        -- We should never see a saturated application of funTyCon; such
        -- applications should be represented with the FunTy constructor.
        -- See Note [Linting function types] and
        -- Note [Representation of function types].
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Saturated application of (->)") 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
           ; [LintedType]
    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
           ; LintedType -> LintedType -> [LintedType] -> LintM ()
    lint_ty_app LintedType
    ty (TyCon -> LintedType
    tyConKind TyCon
    tc) [LintedType]
    tys'
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyCon -> [LintedType] -> LintedType
    TyConApp TyCon
    tc [LintedType]
    tys') }

    -- arrows can related *unlifted* kinds, so this has to be separate from
    -- a dependent forall.
    lintType ty :: LintedType
    ty@(FunTy AnonArgFlag
    af LintedType
    tw LintedType
    t1 LintedType
    t2)
      = do { LintedType
    t1' <- LintedType -> LintM LintedType
    lintType LintedType
    t1
           ; LintedType
    t2' <- LintedType -> LintM LintedType
    lintType LintedType
    t2
           ; LintedType
    tw' <- LintedType -> LintM LintedType
    lintType LintedType
    tw
           ; SDoc -> LintedType -> LintedType -> LintedType -> LintM ()
    lintArrow (String -> SDoc
    text String
    "type or kind" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)) LintedType
    t1' LintedType
    t2' LintedType
    tw'
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (AnonArgFlag -> LintedType -> LintedType -> LintedType -> LintedType
    FunTy AnonArgFlag
    af LintedType
    tw' LintedType
    t1' LintedType
    t2') }

    lintType ty :: LintedType
    ty@(ForAllTy (Bndr Var
    tcv ArgFlag
    vis) LintedType
    body_ty)
      | Bool -> Bool
    not (Var -> Bool
    isTyCoVar Var
    tcv)
      = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    text String
    "Non-Tyvar or Non-Covar bound in type:" SDoc -> SDoc -> SDoc
    <+> 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 { LintedType
    body_ty' <- LintedType -> LintM LintedType
    lintType LintedType
    body_ty
           ; Var -> LintedType -> LintM ()
    lintForAllBody Var
    tcv' LintedType
    body_ty'

           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Var -> Bool
    isCoVar Var
    tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             Bool -> SDoc -> LintM ()
    lintL (Var
    tcv Var -> IdSet -> Bool
    `elemVarSet` LintedType -> IdSet
    tyCoVarsOfType LintedType
    body_ty) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             String -> SDoc
    text String
    "Covar does not occur in the body:" SDoc -> SDoc -> SDoc
    <+> (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tcv SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    body_ty)
             -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]
             -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo]

           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyCoVarBinder -> LintedType -> LintedType
    ForAllTy (Var -> ArgFlag -> TyCoVarBinder
    forall var argf. var -> argf -> VarBndr var argf
    Bndr Var
    tcv' ArgFlag
    vis) LintedType
    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 { LintedType
    ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; Coercion
    co' <- Coercion -> LintM Coercion
    lintStarCoercion Coercion
    co
           ; let tyk :: LintedType
    tyk = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty'
                 cok :: LintedType
    cok = Coercion -> LintedType
    coercionLKind Coercion
    co'
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    tyk LintedType
    cok (LintedType -> Coercion -> LintedType -> LintedType -> SDoc
    mkCastTyErr LintedType
    ty Coercion
    co LintedType
    tyk LintedType
    cok)
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType -> Coercion -> LintedType
    CastTy LintedType
    ty' Coercion
    co') }

    lintType (CoercionTy Coercion
    co)
      = do { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> LintedType
    CoercionTy Coercion
    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
    text String
    "the body of forall:" SDoc -> SDoc -> SDoc
    <+> 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 = (() :: Constraint) => 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
    text String
    "Variable escape in forall:")
                             JoinArity
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "tyvar:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tcv
                                     , String -> SDoc
    text String
    "type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    body_ty
                                     , String -> SDoc
    text String
    "kind:" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "Un-saturated type application") JoinArity
    2 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty))

      -- Deal with type synonyms
      | Just ([(Var, LintedType)]
    tenv, LintedType
    rhs, [LintedType]
    tys') <- TyCon
    -> [LintedType]
    -> Maybe ([(Var, LintedType)], LintedType, [LintedType])
    forall tyco.
    TyCon -> [tyco] -> Maybe ([(Var, tyco)], LintedType, [tyco])
    expandSynTyCon_maybe TyCon
    tc [LintedType]
    tys
      , let expanded_ty :: LintedType
    expanded_ty = LintedType -> [LintedType] -> LintedType
    mkAppTys ((() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy ([(Var, LintedType)] -> TCvSubst
    mkTvSubstPrs [(Var, LintedType)]
    tenv) LintedType
    rhs) [LintedType]
    tys'
      = do { -- Kind-check the argument types, but without reporting
             -- un-saturated type families/synonyms
             [LintedType]
    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)

           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    report_unsat (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             do { LintedType
    _ <- LintedType -> LintM LintedType
    lintType LintedType
    expanded_ty
                ; () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () }

           ; LintedType -> LintedType -> [LintedType] -> LintM ()
    lint_ty_app LintedType
    ty (TyCon -> LintedType
    tyConKind TyCon
    tc) [LintedType]
    tys'
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyCon -> [LintedType] -> LintedType
    TyConApp TyCon
    tc [LintedType]
    tys') }

      -- Otherwise this must be a type family
      | Bool
    otherwise
      = do { [LintedType]
    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
           ; LintedType -> LintedType -> [LintedType] -> LintM ()
    lint_ty_app LintedType
    ty (TyCon -> LintedType
    tyConKind TyCon
    tc) [LintedType]
    tys'
           ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyCon -> [LintedType] -> LintedType
    TyConApp TyCon
    tc [LintedType]
    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
    classifiesTypeWithValues LintedType
    kind)
              (String -> SDoc
    text String
    "Non-Type-like kind when Type-like expected:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kind SDoc -> SDoc -> SDoc
    $$
               String -> SDoc
    text String
    "when checking" SDoc -> SDoc -> SDoc
    <+> SDoc
    doc)
      where
        kind :: LintedType
    kind = (() :: Constraint) => 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
    classifiesTypeWithValues LintedType
    k1) (SDoc -> LintM ()
    addErrL (SDoc -> LintedType -> SDoc
    msg (String -> SDoc
    text String
    "argument") LintedType
    k1))
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType -> Bool
    classifiesTypeWithValues LintedType
    k2) (SDoc -> LintM ()
    addErrL (SDoc -> LintedType -> SDoc
    msg (String -> SDoc
    text String
    "result")   LintedType
    k2))
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType -> Bool
    isMultiplicityTy LintedType
    kw) (SDoc -> LintM ()
    addErrL (SDoc -> LintedType -> SDoc
    msg (String -> SDoc
    text String
    "multiplicity") LintedType
    kw)) }
      where
        k1 :: LintedType
    k1 = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t1
        k2 :: LintedType
    k2 = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t2
        kw :: LintedType
    kw = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    tw
        msg :: SDoc -> LintedType -> SDoc
    msg SDoc
    ar LintedType
    k
          = [SDoc] -> SDoc
    vcat [ SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Ill-kinded" SDoc -> SDoc -> SDoc
    <+> SDoc
    ar)
                      JoinArity
    2 (String -> SDoc
    text String
    "in" SDoc -> SDoc -> SDoc
    <+> SDoc
    what)
                 , SDoc
    what SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "kind:" SDoc -> SDoc -> SDoc
    <+> 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
    ty LintedType
    k [LintedType]
    tys
      = SDoc -> LintedType -> [LintedType] -> LintM ()
    lint_app (String -> SDoc
    text String
    "type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty)) LintedType
    k [LintedType]
    tys

    ----------------
    lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()
    lint_co_app :: Coercion -> LintedType -> [LintedType] -> LintM ()
    lint_co_app Coercion
    ty LintedType
    k [LintedType]
    tys
      = SDoc -> LintedType -> [LintedType] -> LintM ()
    lint_app (String -> SDoc
    text String
    "coercion" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    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
    text String
    "Negative type literal:" SDoc -> SDoc -> SDoc
    <+> Integer -> SDoc
    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 :: SDoc -> 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]
    lint_app :: SDoc -> LintedType -> [LintedType] -> LintM ()
    lint_app SDoc
    doc LintedType
    kfn [LintedType]
    arg_tys
        = do { InScopeSet
    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
             ; LintedType
    _ <- (LintedType -> LintedType -> LintM LintedType)
    -> LintedType -> [LintedType] -> LintM LintedType
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldlM (InScopeSet -> LintedType -> LintedType -> LintM LintedType
    go_app InScopeSet
    in_scope) LintedType
    kfn [LintedType]
    arg_tys
             ; () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () }
      where
        fail_msg :: SDoc -> SDoc
    fail_msg SDoc
    extra = [SDoc] -> SDoc
    vcat [ SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Kind application error in") JoinArity
    2 SDoc
    doc
                              , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (String -> SDoc
    text String
    "Function kind =" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kfn)
                              , JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (String -> SDoc
    text String
    "Arg types =" SDoc -> SDoc -> SDoc
    <+> [LintedType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [LintedType]
    arg_tys)
                              , SDoc
    extra ]

        go_app :: InScopeSet -> LintedType -> LintedType -> LintM LintedType
    go_app InScopeSet
    in_scope LintedType
    kfn LintedType
    ta
          | Just LintedType
    kfn' <- LintedType -> Maybe LintedType
    coreView LintedType
    kfn
          = InScopeSet -> LintedType -> LintedType -> LintM LintedType
    go_app InScopeSet
    in_scope LintedType
    kfn' LintedType
    ta

        go_app InScopeSet
    _ fun_kind :: LintedType
    fun_kind@(FunTy AnonArgFlag
    _ LintedType
    _ LintedType
    kfa LintedType
    kfb) LintedType
    ta
          = do { let ka :: LintedType
    ka = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ta
               ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    ka LintedType -> LintedType -> Bool
    `eqType` LintedType
    kfa) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                 SDoc -> LintM ()
    addErrL (SDoc -> SDoc
    fail_msg (String -> SDoc
    text String
    "Fun:" SDoc -> SDoc -> SDoc
    <+> (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    fun_kind SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ta SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ka)))
               ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LintedType
    kfb }

        go_app InScopeSet
    in_scope (ForAllTy (Bndr Var
    kv ArgFlag
    _vis) LintedType
    kfn) LintedType
    ta
          = do { let kv_kind :: LintedType
    kv_kind = Var -> LintedType
    varType Var
    kv
                     ka :: LintedType
    ka      = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ta
               ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    ka LintedType -> LintedType -> Bool
    `eqType` LintedType
    kv_kind) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
                 SDoc -> LintM ()
    addErrL (SDoc -> SDoc
    fail_msg (String -> SDoc
    text String
    "Forall:" SDoc -> SDoc -> SDoc
    <+> (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    kv SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kv_kind SDoc -> SDoc -> SDoc
    $$
                                                        LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ta SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ka)))
               ; LintedType -> LintM LintedType
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType -> LintM LintedType) -> LintedType -> LintM LintedType
    forall a b. (a -> b) -> a -> b
    $ (() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy (TCvSubst -> Var -> LintedType -> TCvSubst
    extendTCvSubst (InScopeSet -> TCvSubst
    mkEmptyTCvSubst InScopeSet
    in_scope) Var
    kv LintedType
    ta) LintedType
    kfn }

        go_app InScopeSet
    _ LintedType
    kfn LintedType
    ta
           = SDoc -> LintM LintedType
    forall a. SDoc -> LintM a
    failWithL (SDoc -> SDoc
    fail_msg (String -> SDoc
    text String
    "Not a fun:" SDoc -> SDoc -> SDoc
    <+> (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    kfn SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ta)))

    {- *********************************************************************
    *                                                                      *
            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 { (LintedType
    lhs_ty, UsageEnv
    _) <- (LintedType, UsageEnv)
    -> [CoreExpr] -> LintM (LintedType, UsageEnv)
    lintCoreArgs (LintedType
    fun_ty, UsageEnv
    zeroUE) [CoreExpr]
    args
           ; (LintedType
    rhs_ty, UsageEnv
    _) <- case Var -> Maybe JoinArity
    isJoinId_maybe Var
    fun of
                         Just 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 }
                         Maybe JoinArity
    _ -> 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
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    lhs_ty LintedType
    rhs_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             (SDoc
    rule_doc SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "lhs type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    lhs_ty
                                , String -> SDoc
    text String
    "rhs type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs_ty
                                , String -> SDoc
    text String
    "fun_ty:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    fun_ty ])
           ; let bad_bndrs :: [Var]
    bad_bndrs = (Var -> Bool) -> [Var] -> [Var]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Var -> Bool
    is_bad_bndr [Var]
    bndrs

           ; Bool -> SDoc -> LintM ()
    checkL ([Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    bad_bndrs)
                    (SDoc
    rule_doc SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "unbound" SDoc -> SDoc -> SDoc
    <+> [Var] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Var]
    bad_bndrs)
                -- See Note [Linting rules]
        }
      where
        rule_doc :: SDoc
    rule_doc = String -> SDoc
    text String
    "Rule" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    doubleQuotes (FastString -> SDoc
    ftext FastString
    name) SDoc -> SDoc -> SDoc
    <> SDoc
    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
    * NthCo (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 { Coercion
    g' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    g
           ; let Pair LintedType
    t1 LintedType
    t2 = Coercion -> Pair LintedType
    coercionKind Coercion
    g'
           ; LintedType -> SDoc -> LintM ()
    checkValueType LintedType
    t1 (String -> SDoc
    text String
    "the kind of the left type in" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    g)
           ; LintedType -> SDoc -> LintM ()
    checkValueType LintedType
    t2 (String -> SDoc
    text String
    "the kind of the right type in" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    g)
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    g Role
    Nominal (Coercion -> Role
    coercionRole Coercion
    g)
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Coercion
    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
    text String
    "Bad CoVarCo:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    cv)
                      JoinArity
    2 (String -> SDoc
    text String
    "With offending type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    varType Var
    cv)))

      | Bool
    otherwise
      = do { TCvSubst
    subst <- LintM TCvSubst
    getTCvSubst
           ; case TCvSubst -> Var -> Maybe Coercion
    lookupCoVar TCvSubst
    subst Var
    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
                  | Var
    cv Var -> TCvSubst -> Bool
    `isInScope` TCvSubst
    subst
                       -> Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> Coercion
    CoVarCo Var
    cv)
                  | Bool
    otherwise
                       ->
                          -- lintCoBndr always extends the substitition
                          SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (SDoc -> LintM Coercion) -> SDoc -> LintM Coercion
    forall a b. (a -> b) -> a -> b
    $
                          SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "The coercion variable" SDoc -> SDoc -> SDoc
    <+> BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    cv)
                             JoinArity
    2 (String -> SDoc
    text String
    "is out of scope")
         }

    lintCoercion (Refl LintedType
    ty)
      = do { LintedType
    ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LintedType -> Coercion
    Refl LintedType
    ty') }

    lintCoercion (GRefl Role
    r LintedType
    ty MCoercion
    MRefl)
      = do { LintedType
    ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Role -> LintedType -> MCoercion -> Coercion
    GRefl Role
    r LintedType
    ty' MCoercion
    MRefl) }

    lintCoercion (GRefl Role
    r LintedType
    ty (MCo Coercion
    co))
      = do { LintedType
    ty' <- LintedType -> LintM LintedType
    lintType LintedType
    ty
           ; Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let tk :: LintedType
    tk = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty'
                 tl :: LintedType
    tl = Coercion -> LintedType
    coercionLKind Coercion
    co'
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    tk LintedType
    tl (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "GRefl coercion kind mis-match:" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)
                JoinArity
    2 ([SDoc] -> SDoc
    vcat [LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty', LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    tk, LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    tl])
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co' Role
    Nominal (Coercion -> Role
    coercionRole Coercion
    co')
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Role -> LintedType -> MCoercion -> Coercion
    GRefl Role
    r LintedType
    ty' (Coercion -> MCoercion
    MCo Coercion
    co')) }

    lintCoercion co :: Coercion
    co@(TyConAppCo Role
    r TyCon
    tc [Coercion]
    cos)
      | TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    funTyConKey
      , [Coercion
    _w, Coercion
    _rep1,Coercion
    _rep2,Coercion
    _co1,Coercion
    _co2] <- [Coercion]
    cos
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    text String
    "Saturated TyConAppCo (->):" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "Synonym in TyConAppCo:" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)

      | Bool
    otherwise
      = do { TyCon -> LintM ()
    checkTyCon TyCon
    tc
           ; [Coercion]
    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 ([Pair LintedType]
    co_kinds, [Role]
    co_roles) = [(Pair LintedType, Role)] -> ([Pair LintedType], [Role])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ((Coercion -> (Pair LintedType, Role))
    -> [Coercion] -> [(Pair LintedType, Role)]
    forall a b. (a -> b) -> [a] -> [b]
    map Coercion -> (Pair LintedType, Role)
    coercionKindRole [Coercion]
    cos')
           ; Coercion -> LintedType -> [LintedType] -> LintM ()
    lint_co_app Coercion
    co (TyCon -> LintedType
    tyConKind TyCon
    tc) ((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]
    co_kinds)
           ; Coercion -> LintedType -> [LintedType] -> LintM ()
    lint_co_app Coercion
    co (TyCon -> LintedType
    tyConKind TyCon
    tc) ((Pair LintedType -> LintedType)
    -> [Pair LintedType] -> [LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map Pair LintedType -> LintedType
    forall a. Pair a -> a
    pSnd [Pair LintedType]
    co_kinds)
           ; (Role -> Role -> LintM ()) -> [Role] -> [Role] -> LintM ()
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m ()
    zipWithM_ (Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co) (Role -> TyCon -> [Role]
    tyConRolesX Role
    r TyCon
    tc) [Role]
    co_roles
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Role -> TyCon -> [Coercion] -> Coercion
    TyConAppCo Role
    r TyCon
    tc [Coercion]
    cos') }

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

           ; if Role
    r1 Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Phantom
             then Bool -> SDoc -> LintM ()
    lintL (Role
    r2 Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Phantom Bool -> Bool -> Bool
    || Role
    r2 Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Nominal)
                         (String -> SDoc
    text String
    "Second argument in AppCo cannot be R:" SDoc -> SDoc -> SDoc
    $$
                          Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)
             else Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co Role
    Nominal Role
    r2

           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion -> Coercion
    AppCo Coercion
    co1' Coercion
    co2') }

    ----------
    lintCoercion co :: Coercion
    co@(ForAllCo Var
    tcv Coercion
    kind_co Coercion
    body_co)
      | Bool -> Bool
    not (Var -> Bool
    isTyCoVar Var
    tcv)
      = SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (String -> SDoc
    text String
    "Non tyco binder in ForAllCo:" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)
      | Bool
    otherwise
      = do { Coercion
    kind_co' <- Coercion -> LintM Coercion
    lintStarCoercion Coercion
    kind_co
           ; Var -> (Var -> LintM Coercion) -> LintM Coercion
    forall a. Var -> (Var -> LintM a) -> LintM a
    lintTyCoBndr Var
    tcv ((Var -> LintM Coercion) -> LintM Coercion)
    -> (Var -> LintM Coercion) -> LintM Coercion
    forall a b. (a -> b) -> a -> b
    $ \Var
    tcv' ->
        do { Coercion
    body_co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    body_co
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys (Var -> LintedType
    varType Var
    tcv') (Coercion -> LintedType
    coercionLKind Coercion
    kind_co') (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             String -> SDoc
    text String
    "Kind mis-match in ForallCo" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    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 LintedType
    lty LintedType
    rty = Coercion -> Pair LintedType
    coercionKind Coercion
    body_co'
           ; Var -> LintedType -> LintM ()
    lintForAllBody Var
    tcv' LintedType
    lty
           ; Var -> LintedType -> LintM ()
    lintForAllBody Var
    tcv' LintedType
    rty

           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Var -> Bool
    isCoVar Var
    tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             Bool -> SDoc -> LintM ()
    lintL (Var -> Coercion -> Bool
    almostDevoidCoVarOfCo Var
    tcv Coercion
    body_co) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             String -> SDoc
    text String
    "Covar can only appear in Refl and GRefl: " SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co
             -- See "last wrinkle" in GHC.Core.Coercion
             -- Note [Unused coercion variable in ForAllCo]
             -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]

           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> Coercion -> Coercion -> Coercion
    ForAllCo Var
    tcv' Coercion
    kind_co' Coercion
    body_co') } }

    lintCoercion co :: Coercion
    co@(FunCo Role
    r Coercion
    cow Coercion
    co1 Coercion
    co2)
      = do { Coercion
    co1' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co1
           ; Coercion
    co2' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co2
           ; Coercion
    cow' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    cow
           ; let Pair LintedType
    lt1 LintedType
    rt1 = Coercion -> Pair LintedType
    coercionKind Coercion
    co1
                 Pair LintedType
    lt2 LintedType
    rt2 = Coercion -> Pair LintedType
    coercionKind Coercion
    co2
                 Pair LintedType
    ltw LintedType
    rtw = Coercion -> Pair LintedType
    coercionKind Coercion
    cow
           ; SDoc -> LintedType -> LintedType -> LintedType -> LintM ()
    lintArrow (String -> SDoc
    text String
    "coercion" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)) LintedType
    lt1 LintedType
    lt2 LintedType
    ltw
           ; SDoc -> LintedType -> LintedType -> LintedType -> LintM ()
    lintArrow (String -> SDoc
    text String
    "coercion" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)) LintedType
    rt1 LintedType
    rt2 LintedType
    rtw
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co1 Role
    r (Coercion -> Role
    coercionRole Coercion
    co1)
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co2 Role
    r (Coercion -> Role
    coercionRole Coercion
    co2)
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ltw) LintedType
    multiplicityTy (String -> SDoc
    text String
    "coercion" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co))
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    rtw) LintedType
    multiplicityTy (String -> SDoc
    text String
    "coercion" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co))
           ; let expected_mult_role :: Role
    expected_mult_role = case Role
    r of
                                        Role
    Phantom -> Role
    Phantom
                                        Role
    _ -> Role
    Nominal
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    cow Role
    expected_mult_role (Coercion -> Role
    coercionRole Coercion
    cow)
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Role -> Coercion -> Coercion -> Coercion -> Coercion
    FunCo Role
    r Coercion
    cow' Coercion
    co1' Coercion
    co2') }

    -- See Note [Bad unsafe coercion]
    lintCoercion co :: Coercion
    co@(UnivCo UnivCoProvenance
    prov Role
    r LintedType
    ty1 LintedType
    ty2)
      = do { LintedType
    ty1' <- LintedType -> LintM LintedType
    lintType LintedType
    ty1
           ; LintedType
    ty2' <- LintedType -> LintM LintedType
    lintType LintedType
    ty2
           ; let k1 :: LintedType
    k1 = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty1'
                 k2 :: LintedType
    k2 = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty2'
           ; UnivCoProvenance
    prov' <- LintedType
    -> LintedType -> UnivCoProvenance -> LintM UnivCoProvenance
    lint_prov LintedType
    k1 LintedType
    k2 UnivCoProvenance
    prov

           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Role
    r Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Role
    Phantom Bool -> Bool -> Bool
    && LintedType -> Bool
    classifiesTypeWithValues LintedType
    k1
                                Bool -> Bool -> Bool
    && LintedType -> Bool
    classifiesTypeWithValues LintedType
    k2)
                  (LintedType -> LintedType -> LintM ()
    checkTypes LintedType
    ty1 LintedType
    ty2)

           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UnivCoProvenance -> Role -> LintedType -> LintedType -> Coercion
    UnivCo UnivCoProvenance
    prov' Role
    r LintedType
    ty1' LintedType
    ty2') }
       where
         report :: String -> SDoc
    report String
    s = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    vcat [ String -> SDoc
    text String
    "From:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty1
                                 , String -> SDoc
    text String
    "  To:" SDoc -> SDoc -> SDoc
    <+> 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
           | UnivCoProvenance -> Bool
    allow_ill_kinded_univ_co UnivCoProvenance
    prov
           = () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()  -- Skip kind checks
           | Bool
    otherwise
           = 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 = LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    t1
             fixed_rep_2 :: Bool
    fixed_rep_2 = LintedType -> Bool
    typeHasFixedRuntimeRep LintedType
    t2

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

         -- CorePrep deliberately makes ill-kinded casts
         --  e.g (case error @Int "blah" of {}) :: Int#
         --     ==> (error @Int "blah") |> Unsafe Int Int#
         -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep
         allow_ill_kinded_univ_co :: UnivCoProvenance -> Bool
    allow_ill_kinded_univ_co (CorePrepProv Bool
    homo_kind) = Bool -> Bool
    not Bool
    homo_kind
         allow_ill_kinded_univ_co UnivCoProvenance
    _                        = Bool
    False

         validateCoercion :: PrimRep -> PrimRep -> LintM ()
         validateCoercion :: PrimRep -> PrimRep -> LintM ()
    validateCoercion PrimRep
    rep1 PrimRep
    rep2
           = do { Platform
    platform <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> LintM DynFlags -> LintM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LintM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
                ; Bool -> SDoc -> LintM ()
    checkWarnL (PrimRep -> Bool
    isUnBoxed PrimRep
    rep1 Bool -> Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == PrimRep -> Bool
    isUnBoxed PrimRep
    rep2)
                             (String -> SDoc
    report String
    "between unboxed and boxed value")
                ; Bool -> SDoc -> LintM ()
    checkWarnL (Platform -> PrimRep -> JoinArity
    TyCon.primRepSizeB Platform
    platform PrimRep
    rep1
                               JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Platform -> PrimRep -> JoinArity
    TyCon.primRepSizeB Platform
    platform PrimRep
    rep2)
                             (String -> SDoc
    report String
    "between unboxed values of different size")
                ; let fl :: Maybe Bool
    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 Maybe Bool
    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 ()
                }

         lint_prov :: LintedType
    -> LintedType -> UnivCoProvenance -> LintM UnivCoProvenance
    lint_prov LintedType
    k1 LintedType
    k2 (PhantomProv Coercion
    kco)
           = do { Coercion
    kco' <- Coercion -> LintM Coercion
    lintStarCoercion Coercion
    kco
                ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co Role
    Phantom Role
    r
                ; Coercion -> LintedType -> LintedType -> LintM ()
    check_kinds Coercion
    kco' LintedType
    k1 LintedType
    k2
                ; UnivCoProvenance -> LintM UnivCoProvenance
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> UnivCoProvenance
    PhantomProv Coercion
    kco') }

         lint_prov LintedType
    k1 LintedType
    k2 (ProofIrrelProv Coercion
    kco)
           = do { Bool -> SDoc -> LintM ()
    lintL (LintedType -> Bool
    isCoercionTy LintedType
    ty1) (LintedType -> Coercion -> SDoc
    mkBadProofIrrelMsg LintedType
    ty1 Coercion
    co)
                ; Bool -> SDoc -> LintM ()
    lintL (LintedType -> Bool
    isCoercionTy LintedType
    ty2) (LintedType -> Coercion -> SDoc
    mkBadProofIrrelMsg LintedType
    ty2 Coercion
    co)
                ; Coercion
    kco' <- Coercion -> LintM Coercion
    lintStarCoercion Coercion
    kco
                ; Coercion -> LintedType -> LintedType -> LintM ()
    check_kinds Coercion
    kco LintedType
    k1 LintedType
    k2
                ; UnivCoProvenance -> LintM UnivCoProvenance
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> UnivCoProvenance
    ProofIrrelProv Coercion
    kco') }

         lint_prov LintedType
    _ LintedType
    _ prov :: UnivCoProvenance
    prov@(PluginProv String
    _)   = UnivCoProvenance -> LintM UnivCoProvenance
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UnivCoProvenance
    prov
         lint_prov LintedType
    _ LintedType
    _ prov :: UnivCoProvenance
    prov@(CorePrepProv Bool
    _) = UnivCoProvenance -> LintM UnivCoProvenance
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UnivCoProvenance
    prov

         check_kinds :: Coercion -> LintedType -> LintedType -> LintM ()
    check_kinds Coercion
    kco LintedType
    k1 LintedType
    k2
           = do { let Pair LintedType
    k1' LintedType
    k2' = Coercion -> Pair LintedType
    coercionKind Coercion
    kco
                ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    k1 LintedType
    k1' (LeftOrRight -> Coercion -> SDoc
    mkBadUnivCoMsg LeftOrRight
    CLeft  Coercion
    co)
                ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    k2 LintedType
    k2' (LeftOrRight -> Coercion -> SDoc
    mkBadUnivCoMsg LeftOrRight
    CRight Coercion
    co) }

    lintCoercion (SymCo Coercion
    co)
      = do { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion
    SymCo Coercion
    co') }

    lintCoercion co :: Coercion
    co@(TransCo Coercion
    co1 Coercion
    co2)
      = do { Coercion
    co1' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co1
           ; Coercion
    co2' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co2
           ; let ty1b :: LintedType
    ty1b = Coercion -> LintedType
    coercionRKind Coercion
    co1'
                 ty2a :: LintedType
    ty2a = Coercion -> LintedType
    coercionLKind Coercion
    co2'
           ; LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    ty1b LintedType
    ty2a
                   (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Trans coercion mis-match:" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co)
                       JoinArity
    2 ([SDoc] -> SDoc
    vcat [Pair LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Coercion -> Pair LintedType
    coercionKind Coercion
    co1'), Pair LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Coercion -> Pair LintedType
    coercionKind Coercion
    co2')]))
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co (Coercion -> Role
    coercionRole Coercion
    co1) (Coercion -> Role
    coercionRole Coercion
    co2)
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion -> Coercion
    TransCo Coercion
    co1' Coercion
    co2') }

    lintCoercion the_co :: Coercion
    the_co@(NthCo Role
    r0 JoinArity
    n Coercion
    co)
      = do { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let (Pair LintedType
    s LintedType
    t, Role
    r) = Coercion -> (Pair LintedType, Role)
    coercionKindRole Coercion
    co'
           ; case (LintedType -> Maybe (Var, LintedType)
    splitForAllTyCoVar_maybe LintedType
    s, LintedType -> Maybe (Var, LintedType)
    splitForAllTyCoVar_maybe LintedType
    t) of
             { (Just (Var, LintedType)
    _, Just (Var, LintedType)
    _)
                 -- works for both tyvar and covar
                 | JoinArity
    n JoinArity -> JoinArity -> Bool
    forall a. Eq a => a -> a -> Bool
    == JoinArity
    0
                 ,  (LintedType -> Bool
    isForAllTy_ty LintedType
    s Bool -> Bool -> Bool
    && LintedType -> Bool
    isForAllTy_ty LintedType
    t)
                 Bool -> Bool -> Bool
    || (LintedType -> Bool
    isForAllTy_co LintedType
    s Bool -> Bool -> Bool
    && LintedType -> Bool
    isForAllTy_co LintedType
    t)
                 -> do { Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    the_co Role
    Nominal Role
    r0
                       ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Role -> JoinArity -> Coercion -> Coercion
    NthCo Role
    r0 JoinArity
    n Coercion
    co') }

             ; (Maybe (Var, LintedType), Maybe (Var, LintedType))
    _ -> case ((() :: Constraint) => LintedType -> Maybe (TyCon, [LintedType])
    LintedType -> Maybe (TyCon, [LintedType])
    splitTyConApp_maybe LintedType
    s, (() :: Constraint) => LintedType -> Maybe (TyCon, [LintedType])
    LintedType -> Maybe (TyCon, [LintedType])
    splitTyConApp_maybe LintedType
    t) of
             { (Just (TyCon
    tc_s, [LintedType]
    tys_s), Just (TyCon
    tc_t, [LintedType]
    tys_t))
                 | TyCon
    tc_s TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    tc_t
                 , TyCon -> Role -> Bool
    isInjectiveTyCon TyCon
    tc_s Role
    r
                     -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep
                 , [LintedType]
    tys_s [LintedType] -> [LintedType] -> Bool
    forall a b. [a] -> [b] -> Bool
    `equalLength` [LintedType]
    tys_t
                 , [LintedType]
    tys_s [LintedType] -> JoinArity -> Bool
    forall a. [a] -> JoinArity -> Bool
    `lengthExceeds` JoinArity
    n
                 -> do { Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    the_co Role
    tr Role
    r0
                       ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Role -> JoinArity -> Coercion -> Coercion
    NthCo Role
    r0 JoinArity
    n Coercion
    co') }
                    where
                      tr :: Role
    tr = Role -> TyCon -> JoinArity -> Role
    nthRole Role
    r TyCon
    tc_s JoinArity
    n

             ; (Maybe (TyCon, [LintedType]), Maybe (TyCon, [LintedType]))
    _ -> SDoc -> LintM Coercion
    forall a. SDoc -> LintM a
    failWithL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Bad getNth:")
                                  JoinArity
    2 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    the_co SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    s SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    t)) }}}

    lintCoercion the_co :: Coercion
    the_co@(LRCo LeftOrRight
    lr Coercion
    co)
      = do { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; let Pair LintedType
    s LintedType
    t = Coercion -> Pair LintedType
    coercionKind Coercion
    co'
                 r :: Role
    r        = Coercion -> Role
    coercionRole Coercion
    co'
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co Role
    Nominal Role
    r
           ; case (LintedType -> Maybe (LintedType, LintedType)
    splitAppTy_maybe LintedType
    s, LintedType -> Maybe (LintedType, LintedType)
    splitAppTy_maybe LintedType
    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
    text String
    "Bad LRCo:")
                                  JoinArity
    2 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    the_co SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    s SDoc -> SDoc -> SDoc
    $$ LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    t)) }

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

           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    arg Role
    Nominal (Coercion -> Role
    coercionRole Coercion
    arg')

          ; case (LintedType -> Maybe (Var, LintedType)
    splitForAllTyVar_maybe LintedType
    t1, LintedType -> Maybe (Var, LintedType)
    splitForAllTyVar_maybe LintedType
    t2) of
             -- forall over tvar
             { (Just (Var
    tv1,LintedType
    _), Just (Var
    tv2,LintedType
    _))
                 | (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s1 LintedType -> LintedType -> Bool
    `eqType` Var -> LintedType
    tyVarKind Var
    tv1
                 , (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s2 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
    text String
    "Kind mis-match in inst coercion1" SDoc -> SDoc -> SDoc
    <+> 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
    _))
                 | (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s1 LintedType -> LintedType -> Bool
    `eqType` Var -> LintedType
    varType Var
    cv1
                 , (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s2 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
    text String
    "Kind mis-match in inst coercion2" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "Bad argument of inst") }}}

    lintCoercion co :: Coercion
    co@(AxiomInstCo CoAxiom Branched
    con JoinArity
    ind [Coercion]
    cos)
      = do { Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (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
    con))
                    (SDoc -> LintM ()
    bad_ax (String -> SDoc
    text String
    "index out of range"))
           ; let CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
    cab_tvs   = [Var]
    ktvs
                            , cab_cvs :: CoAxBranch -> [Var]
    cab_cvs   = [Var]
    cvs
                            , cab_roles :: CoAxBranch -> [Role]
    cab_roles = [Role]
    roles } = CoAxiom Branched -> JoinArity -> CoAxBranch
    forall (br :: BranchFlag). CoAxiom br -> JoinArity -> CoAxBranch
    coAxiomNthBranch CoAxiom Branched
    con JoinArity
    ind
           ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([Coercion]
    cos [Coercion] -> [Var] -> Bool
    forall a b. [a] -> [b] -> Bool
    `equalLength` ([Var]
    ktvs [Var] -> [Var] -> [Var]
    forall a. [a] -> [a] -> [a]
    ++ [Var]
    cvs)) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
               SDoc -> LintM ()
    bad_ax (String -> SDoc
    text String
    "lengths")
           ; [Coercion]
    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
           ; TCvSubst
    subst <- LintM TCvSubst
    getTCvSubst
           ; let empty_subst :: TCvSubst
    empty_subst = TCvSubst -> TCvSubst
    zapTCvSubst TCvSubst
    subst
           ; (TCvSubst, TCvSubst)
    _ <- ((TCvSubst, TCvSubst)
     -> (Var, Role, Coercion) -> LintM (TCvSubst, TCvSubst))
    -> (TCvSubst, TCvSubst)
    -> [(Var, Role, Coercion)]
    -> LintM (TCvSubst, TCvSubst)
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldlM (TCvSubst, TCvSubst)
    -> (Var, Role, Coercion) -> LintM (TCvSubst, TCvSubst)
    check_ki (TCvSubst
    empty_subst, TCvSubst
    empty_subst)
                                  ([Var] -> [Role] -> [Coercion] -> [(Var, Role, Coercion)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 ([Var]
    ktvs [Var] -> [Var] -> [Var]
    forall a. [a] -> [a] -> [a]
    ++ [Var]
    cvs) [Role]
    roles [Coercion]
    cos')
           ; let fam_tc :: TyCon
    fam_tc = CoAxiom Branched -> TyCon
    forall (br :: BranchFlag). CoAxiom br -> TyCon
    coAxiomTyCon CoAxiom Branched
    con
           ; case Coercion -> Maybe CoAxBranch
    checkAxInstCo Coercion
    co of
               Just CoAxBranch
    bad_branch -> SDoc -> LintM ()
    bad_ax (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text String
    "inconsistent with" SDoc -> SDoc -> SDoc
    <+>
                                           TyCon -> CoAxBranch -> SDoc
    pprCoAxBranch TyCon
    fam_tc CoAxBranch
    bad_branch
               Maybe CoAxBranch
    Nothing -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoAxiom Branched -> JoinArity -> [Coercion] -> Coercion
    AxiomInstCo CoAxiom Branched
    con JoinArity
    ind [Coercion]
    cos') }
      where
        bad_ax :: SDoc -> LintM ()
    bad_ax SDoc
    what = SDoc -> LintM ()
    addErrL (SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text  String
    "Bad axiom application" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens SDoc
    what)
                            JoinArity
    2 (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co))

        check_ki :: (TCvSubst, TCvSubst)
    -> (Var, Role, Coercion) -> LintM (TCvSubst, TCvSubst)
    check_ki (TCvSubst
    subst_l, TCvSubst
    subst_r) (Var
    ktv, Role
    role, Coercion
    arg')
          = do { let Pair LintedType
    s' LintedType
    t' = Coercion -> Pair LintedType
    coercionKind Coercion
    arg'
                     sk' :: LintedType
    sk' = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    s'
                     tk' :: LintedType
    tk' = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    t'
               ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    arg' Role
    role (Coercion -> Role
    coercionRole Coercion
    arg')
               ; let ktv_kind_l :: LintedType
    ktv_kind_l = (() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy TCvSubst
    subst_l (Var -> LintedType
    tyVarKind Var
    ktv)
                     ktv_kind_r :: LintedType
    ktv_kind_r = (() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy TCvSubst
    subst_r (Var -> LintedType
    tyVarKind Var
    ktv)
               ; Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    sk' LintedType -> LintedType -> Bool
    `eqType` LintedType
    ktv_kind_l)
                        (SDoc -> LintM ()
    bad_ax (String -> SDoc
    text String
    "check_ki1" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    vcat [ Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    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 -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (LintedType
    tk' LintedType -> LintedType -> Bool
    `eqType` LintedType
    ktv_kind_r)
                        (SDoc -> LintM ()
    bad_ax (String -> SDoc
    text String
    "check_ki2" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    vcat [ Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    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 ] ))
               ; (TCvSubst, TCvSubst) -> LintM (TCvSubst, TCvSubst)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TCvSubst -> Var -> LintedType -> TCvSubst
    extendTCvSubst TCvSubst
    subst_l Var
    ktv LintedType
    s',
                         TCvSubst -> Var -> LintedType -> TCvSubst
    extendTCvSubst TCvSubst
    subst_r Var
    ktv LintedType
    t') }

    lintCoercion (KindCo Coercion
    co)
      = do { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion
    KindCo Coercion
    co') }

    lintCoercion (SubCo Coercion
    co')
      = do { Coercion
    co' <- Coercion -> LintM Coercion
    lintCoercion Coercion
    co'
           ; Coercion -> Role -> Role -> LintM ()
    forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
    lintRole Coercion
    co' Role
    Nominal (Coercion -> Role
    coercionRole Coercion
    co')
           ; Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Coercion -> Coercion
    SubCo Coercion
    co') }

    lintCoercion this :: Coercion
    this@(AxiomRuleCo CoAxiomRule
    ax [Coercion]
    cos)
      = do { [Coercion]
    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
           ; JoinArity -> [Role] -> [Coercion] -> LintM ()
    lint_roles JoinArity
    0 (CoAxiomRule -> [Role]
    coaxrAsmpRoles CoAxiomRule
    ax) [Coercion]
    cos'
           ; case CoAxiomRule -> [Pair LintedType] -> Maybe (Pair LintedType)
    coaxrProves CoAxiomRule
    ax ((Coercion -> Pair LintedType) -> [Coercion] -> [Pair LintedType]
    forall a b. (a -> b) -> [a] -> [b]
    map Coercion -> Pair LintedType
    coercionKind [Coercion]
    cos') of
               Maybe (Pair LintedType)
    Nothing -> String -> [SDoc] -> LintM Coercion
    forall a. String -> [SDoc] -> LintM a
    err String
    "Malformed use of AxiomRuleCo" [ Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    this ]
               Just Pair LintedType
    _  -> Coercion -> LintM Coercion
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoAxiomRule -> [Coercion] -> Coercion
    AxiomRuleCo CoAxiomRule
    ax [Coercion]
    cos') }
      where
      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
    text String
    m) JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat (String -> SDoc
    text String
    "Rule:" SDoc -> SDoc -> SDoc
    <+> FastString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CoAxiomRule -> FastString
    coaxrName 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
    text String
    "In argument:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    int (JoinArity
    nJoinArity -> JoinArity -> JoinArity
    forall a. Num a => a -> a -> a
    +JoinArity
    1)
                          , String -> SDoc
    text String
    "Expected:" SDoc -> SDoc -> SDoc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Role
    e
                          , String -> SDoc
    text String
    "Found:" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "Expected:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    int JoinArity
    n
                              , String -> SDoc
    text String
    "Provided:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    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
    text String
    "Expected:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    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
    text String
    "Provided:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    int JoinArity
    n ]

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

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

    lintAxioms :: Logger
               -> DynFlags
               -> SDoc -- ^ The source of the linted axioms
               -> [CoAxiom Branched]
               -> IO ()
    lintAxioms :: Logger -> DynFlags -> SDoc -> [CoAxiom Branched] -> IO ()
    lintAxioms Logger
    logger DynFlags
    dflags SDoc
    what [CoAxiom Branched]
    axioms =
      Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
    displayLintResults Logger
    logger Bool
    True SDoc
    what ([SDoc] -> SDoc
    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
    $
      DynFlags -> LintFlags -> [Var] -> LintM () -> WarnsAndErrs
    forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
    initL DynFlags
    dflags (DynFlags -> LintFlags
    defaultLintFlags DynFlags
    dflags) [] (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 :: 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_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
    text String
    "multi-branch axiom with newtype")
               ; let ax_lhs :: LintedType
    ax_lhs = [Var] -> LintedType -> LintedType
    mkInfForAllTys [Var]
    tvs (LintedType -> LintedType) -> LintedType -> LintedType
    forall a b. (a -> b) -> a -> b
    $
                              TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc [LintedType]
    lhs_tys
                     nt_tvs :: [Var]
    nt_tvs = [Var] -> [Var] -> [Var]
    forall b a. [b] -> [a] -> [a]
    takeList [Var]
    tvs (TyCon -> [Var]
    tyConTyVars TyCon
    tc)
                        -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon
                     nt_lhs :: LintedType
    nt_lhs = [Var] -> LintedType -> LintedType
    mkInfForAllTys [Var]
    nt_tvs (LintedType -> LintedType) -> LintedType -> LintedType
    forall a b. (a -> b) -> a -> b
    $
                              TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc ([Var] -> [LintedType]
    mkTyVarTys [Var]
    nt_tvs)
                     -- See Note [Newtype eta] in GHC.Core.TyCon
               ; Bool -> SDoc -> LintM ()
    lintL (LintedType
    ax_lhs LintedType -> LintedType -> Bool
    `eqType` LintedType
    nt_lhs)
                       (String -> SDoc
    text String
    "Newtype axiom LHS does not match newtype definition")
               ; Bool -> SDoc -> LintM ()
    lintL ([Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    cvs)
                       (String -> SDoc
    text String
    "Newtype axiom binds coercion variables")
               ; Bool -> SDoc -> LintM ()
    lintL ([Var] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Var]
    eta_tvs)  -- See Note [Eta reduction for data families]
                                       -- which is not about newtype axioms
                       (String -> SDoc
    text String
    "Newtype axiom has eta-tvs")
               ; Bool -> SDoc -> LintM ()
    lintL (Role
    ax_role Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Representational)
                       (String -> SDoc
    text String
    "Newtype axiom role not representational")
               ; Bool -> SDoc -> LintM ()
    lintL ([Role]
    roles [Role] -> [Var] -> Bool
    forall a b. [a] -> [b] -> Bool
    `equalLength` [Var]
    tvs)
                       (String -> SDoc
    text String
    "Newtype axiom roles list is the wrong length." SDoc -> SDoc -> SDoc
    $$
                        String -> SDoc
    text String
    "roles:" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    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 ([Role]
    roles [Role] -> [Role] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Role] -> [Role] -> [Role]
    forall b a. [b] -> [a] -> [a]
    takeList [Role]
    roles (TyCon -> [Role]
    tyConRoles TyCon
    tc))
                       ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Newtype axiom roles do not match newtype tycon's."
                             , String -> SDoc
    text String
    "axiom roles:" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    sep ((Role -> SDoc) -> [Role] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Role]
    roles)
                             , String -> SDoc
    text String
    "tycon roles:" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    sep ((Role -> SDoc) -> [Role] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (TyCon -> [Role]
    tyConRoles TyCon
    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
    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
    text String
    "data family axiom is not representational")

                    | Bool
    otherwise
                      -> SDoc -> LintM ()
    addErrL (String -> SDoc
    text String
    "A family TyCon is neither a type family nor a data family:" SDoc -> SDoc -> SDoc
    <+> 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
    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
           ; LintedType
    lhs' <- LintedType -> LintM LintedType
    lintType LintedType
    lhs
           ; LintedType
    rhs' <- LintedType -> LintM LintedType
    lintType LintedType
    rhs
           ; let lhs_kind :: LintedType
    lhs_kind = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    lhs'
                 rhs_kind :: LintedType
    rhs_kind = (() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    rhs'
           ; Bool -> SDoc -> LintM ()
    lintL (LintedType
    lhs_kind LintedType -> LintedType -> Bool
    `eqType` LintedType
    rhs_kind) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
             SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Inhomogeneous axiom")
                JoinArity
    2 (String -> SDoc
    text String
    "lhs:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    lhs SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    lhs_kind SDoc -> SDoc -> SDoc
    $$
                   String -> SDoc
    text String
    "rhs:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs_kind) }

    -- 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
    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
    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
    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
    text String
    "Non-nominal role in family axiom" SDoc -> SDoc -> SDoc
    $$
                    String -> SDoc
    text String
    "roles:" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    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
    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
    compatible_branches CoAxBranch
    br CoAxBranch
    br')) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
               String -> SDoc
    text String
    "Incorrect incompatible branch:" SDoc -> SDoc -> SDoc
    <+> 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
    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
    compatible_branches CoAxBranch
    br1 CoAxBranch
    br2) (SDoc -> LintM ()) -> SDoc -> LintM ()
    forall a b. (a -> b) -> a -> b
    $
        [SDoc] -> SDoc
    vcat [ [SDoc] -> SDoc
    hsep [ String -> SDoc
    text String
    "Axioms", CoAxiom Branched -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiom Branched
    ax1, String -> SDoc
    text String
    "and", CoAxiom Branched -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoAxiom Branched
    ax2
                    , String -> SDoc
    text String
    "are incompatible" ]
             , String -> SDoc
    text String
    "tvs1 =" SDoc -> SDoc -> SDoc
    <+> [Var] -> SDoc
    pprTyVars [Var]
    tvs1
             , String -> SDoc
    text String
    "lhs1 =" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc [LintedType]
    lhs1)
             , String -> SDoc
    text String
    "rhs1 =" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs1
             , String -> SDoc
    text String
    "tvs2 =" SDoc -> SDoc -> SDoc
    <+> [Var] -> SDoc
    pprTyVars [Var]
    tvs2
             , String -> SDoc
    text String
    "lhs2 =" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc [LintedType]
    lhs2)
             , String -> SDoc
    text String
    "rhs2 =" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs2 ]

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

    compatible_branches :: CoAxBranch -> CoAxBranch -> Bool
    -- True <=> branches are compatible. See Note [Compatibility] in GHC.Core.FamInstEnv.
    compatible_branches :: CoAxBranch -> CoAxBranch -> Bool
    compatible_branches (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 })
                        (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 })
      = -- we need to freshen ax2 w.r.t. ax1
        -- do this by pretending tvs1 are in scope when processing tvs2
        let in_scope :: InScopeSet
    in_scope       = IdSet -> InScopeSet
    mkInScopeSet ([Var] -> IdSet
    mkVarSet [Var]
    tvs1)
            subst0 :: TCvSubst
    subst0         = InScopeSet -> TCvSubst
    mkEmptyTCvSubst InScopeSet
    in_scope
            (TCvSubst
    subst, [Var]
    _)     = (() :: Constraint) => TCvSubst -> [Var] -> (TCvSubst, [Var])
    TCvSubst -> [Var] -> (TCvSubst, [Var])
    substTyVarBndrs TCvSubst
    subst0 [Var]
    tvs2
            lhs2' :: [LintedType]
    lhs2'          = (() :: Constraint) => TCvSubst -> [LintedType] -> [LintedType]
    TCvSubst -> [LintedType] -> [LintedType]
    substTys TCvSubst
    subst [LintedType]
    lhs2
            rhs2' :: LintedType
    rhs2'          = (() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy  TCvSubst
    subst LintedType
    rhs2
        in
        case BindFun -> [LintedType] -> [LintedType] -> Maybe TCvSubst
    tcUnifyTys BindFun
    alwaysBindFun [LintedType]
    lhs1 [LintedType]
    lhs2' of
          Just TCvSubst
    unifying_subst -> (() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy TCvSubst
    unifying_subst LintedType
    rhs1  LintedType -> LintedType -> Bool
    `eqType`
                                 (() :: Constraint) => TCvSubst -> LintedType -> LintedType
    TCvSubst -> LintedType -> LintedType
    substTy TCvSubst
    unifying_subst LintedType
    rhs2'
          Maybe TCvSubst
    Nothing             -> Bool
    True

    {-
    ************************************************************************
    *                                                                      *
    \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 -> TCvSubst
    le_subst :: TCvSubst  -- 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 TCvSubst 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 -> DynFlags
    le_dynflags :: DynFlags     -- DynamicFlags
           , LintEnv -> NameEnv UsageEnv
    le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the
                                               -- alias-like binders, as found in
                                               -- non-recursive lets.
           }

    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

    defaultLintFlags :: DynFlags -> LintFlags
    defaultLintFlags :: DynFlags -> LintFlags
    defaultLintFlags DynFlags
    dflags = LF { lf_check_global_ids :: Bool
    lf_check_global_ids = Bool
    False
                                 , lf_check_inline_loop_breakers :: Bool
    lf_check_inline_loop_breakers = Bool
    True
                                 , lf_check_static_ptrs :: StaticPtrCheck
    lf_check_static_ptrs = StaticPtrCheck
    AllowAnywhere
                                 , lf_check_linearity :: Bool
    lf_check_linearity = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoLinearCoreLinting DynFlags
    dflags
                                 , lf_report_unsat_syns :: Bool
    lf_report_unsat_syns = Bool
    True
                                 , lf_check_fixed_rep :: Bool
    lf_check_fixed_rep = Bool
    True
                                 }

    newtype LintM a =
       LintM { forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM ::
                LintEnv ->
                WarnsAndErrs ->           -- Warning and error messages so far
                (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
       deriving ((forall a b. (a -> b) -> LintM a -> LintM b)
    -> (forall a b. a -> LintM b -> LintM a) -> Functor LintM
    forall a b. a -> LintM b -> LintM a
    forall a b. (a -> b) -> LintM a -> LintM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
    fmap :: forall a b. (a -> b) -> LintM a -> LintM b
    $c<$ :: forall a b. a -> LintM b -> LintM a
    <$ :: forall a b. a -> LintM b -> LintM a
    Functor)

    type WarnsAndErrs = (Bag SDoc, Bag SDoc)

    {- 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]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    There is one known optimisations that have not yet been updated
    to work with Linear Lint:

    * 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.
      Plan: make let-bound variables remember the usage environment.
      See ticket #18694.

    We plan to fix this issue in the very near future.
    For now, -dcore-lint enables only linting output of the desugarer,
    and full Linear Lint has to be enabled separately with -dlinear-core-lint.
    Ticket #19165 concerns enabling Linear Lint with -dcore-lint.

    Note [checkCanEtaExpand]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    The checkCanEtaExpand function is responsible for enforcing invariant I3
    from Note [Representation polymorphism invariants] in GHC.Core: in any
    partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to
    eta expand `f` to match the declared arity of `f`.

    Wrinkle 1: eta-expansion and newtypes

      Most of the time, when we have a partial application `f e_1 .. e_n`
      in which `f` is `hasNoBinding`, we eta-expand it up to its arity
      as follows:

        \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity

      However, we might need to insert casts if some of the arguments
      that `f` takes are under a newtype.
      For example, suppose `f` `hasNoBinding`, has arity 1 and type

        f :: forall r (a :: TYPE r). Identity (a -> a)

      then we eta-expand the nullary application `f` to

        ( \ x -> f x ) |> co

      where

        co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) )

      In this case we would have to perform a representation-polymorphism check on the instantiation
      of `a`.

    Wrinkle 2: 'hasNoBinding' and laziness

      It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing
      the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in
        Note [Lazily checking Unfoldings] in GHC.IfaceToCore.
    -}

    instance Applicative LintM where
          pure :: forall a. a -> LintM a
    pure a
    x = (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    _ WarnsAndErrs
    errs -> (a -> Maybe a
    forall a. a -> Maybe a
    Just a
    x, WarnsAndErrs
    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 -> (Maybe b, WarnsAndErrs)) -> LintM b
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs ->
                           let (Maybe a
    res, WarnsAndErrs
    errs') = LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m LintEnv
    env WarnsAndErrs
    errs in
                             case Maybe a
    res of
                               Just a
    r -> LintM b -> LintEnv -> WarnsAndErrs -> (Maybe b, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM (a -> LintM b
    k a
    r) LintEnv
    env WarnsAndErrs
    errs'
                               Maybe a
    Nothing -> (Maybe b
    forall a. Maybe a
    Nothing, WarnsAndErrs
    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
    text String
    err)

    instance HasDynFlags LintM where
      getDynFlags :: LintM DynFlags
    getDynFlags = (LintEnv -> WarnsAndErrs -> (Maybe DynFlags, WarnsAndErrs))
    -> LintM DynFlags
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\ LintEnv
    e WarnsAndErrs
    errs -> (DynFlags -> Maybe DynFlags
    forall a. a -> Maybe a
    Just (LintEnv -> DynFlags
    le_dynflags 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
      | BodyOfLetRec [Id]   -- One of the binders
      | 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

    initL :: DynFlags
          -> LintFlags
          -> [Var]              -- ^ 'Id's that should be treated as being in scope
          -> LintM a            -- ^ Action to run
          -> WarnsAndErrs
    initL :: forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
    initL DynFlags
    dflags LintFlags
    flags [Var]
    vars LintM a
    m
      = case LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m LintEnv
    env (Bag SDoc
    forall a. Bag a
    emptyBag, Bag SDoc
    forall a. Bag a
    emptyBag) of
          (Just a
    _, WarnsAndErrs
    errs) -> WarnsAndErrs
    errs
          (Maybe a
    Nothing, 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
    empty
      where
        ([Var]
    tcvs, [Var]
    ids) = (Var -> Bool) -> [Var] -> ([Var], [Var])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition Var -> Bool
    isTyCoVar [Var]
    vars
        env :: LintEnv
    env = LE { le_flags :: LintFlags
    le_flags = LintFlags
    flags
                 , le_subst :: TCvSubst
    le_subst = InScopeSet -> TCvSubst
    mkEmptyTCvSubst (IdSet -> InScopeSet
    mkInScopeSet ([Var] -> IdSet
    mkVarSet [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_dynflags :: DynFlags
    le_dynflags = DynFlags
    dflags
                 , le_ue_aliases :: NameEnv UsageEnv
    le_ue_aliases = NameEnv UsageEnv
    forall a. NameEnv a
    emptyNameEnv }

    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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
        let env' :: LintEnv
    env' = LintEnv
    env { le_flags :: LintFlags
    le_flags = (LintEnv -> LintFlags
    le_flags LintEnv
    env) { lf_report_unsat_syns :: Bool
    lf_report_unsat_syns = Bool
    ru } }
        in LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \LintEnv
    env WarnsAndErrs
    errs ->
        let env' :: LintEnv
    env' = LintEnv
    env { le_flags :: LintFlags
    le_flags = (LintEnv -> LintFlags
    le_flags LintEnv
    env) { lf_check_fixed_rep :: Bool
    lf_check_fixed_rep = Bool
    False } }
        in LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    thing_inside LintEnv
    env' WarnsAndErrs
    errs

    getLintFlags :: LintM LintFlags
    getLintFlags :: LintM LintFlags
    getLintFlags = (LintEnv -> WarnsAndErrs -> (Maybe LintFlags, WarnsAndErrs))
    -> LintM LintFlags
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe LintFlags, WarnsAndErrs))
     -> LintM LintFlags)
    -> (LintEnv -> WarnsAndErrs -> (Maybe LintFlags, WarnsAndErrs))
    -> LintM LintFlags
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> (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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env (Bag SDoc
    warns,Bag SDoc
    errs) ->
                    (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 -> (Maybe (), WarnsAndErrs)) -> LintM ()
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs)) -> LintM ())
    -> (LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs))
    -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env (Bag SDoc
    warns,Bag SDoc
    errs) ->
                  (() -> 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 -> (Maybe (), WarnsAndErrs)) -> LintM ()
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs)) -> LintM ())
    -> (LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs))
    -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env (Bag SDoc
    warns,Bag SDoc
    errs) ->
                  (() -> 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
    vcat [ [SDoc] -> SDoc
    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
    text String
    "Substitution:" SDoc -> SDoc -> SDoc
    <+> TCvSubst -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (LintEnv -> TCvSubst
    le_subst LintEnv
    env) ]
       context :: SDoc
    context | Bool
    is_error  = SDoc
    cxt_doc
               | Bool
    otherwise = SDoc -> SDoc
    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 = DynFlags -> DiagOpts
    initDiagOpts (LintEnv -> DynFlags
    le_dynflags LintEnv
    env)
       mk_msg :: SDoc -> SDoc
    mk_msg SDoc
    msg = MessageClass -> SrcSpan -> SDoc -> SDoc
    mkLocMessage (DiagOpts -> DiagnosticReason -> MessageClass
    mkMCDiagnostic DiagOpts
    diag_opts DiagnosticReason
    WarningWithoutFlag) SrcSpan
    msg_span
                                 (SDoc
    msg SDoc -> SDoc -> SDoc
    $$ 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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
        LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m (LintEnv
    env { le_loc :: [LintLocInfo]
    le_loc = LintLocInfo
    extra_loc LintLocInfo -> [LintLocInfo] -> [LintLocInfo]
    forall a. a -> [a] -> [a]
    : LintEnv -> [LintLocInfo]
    le_loc LintEnv
    env }) WarnsAndErrs
    errs

    inCasePat :: LintM Bool         -- A slight hack; see the unique call site
    inCasePat :: LintM Bool
    inCasePat = (LintEnv -> WarnsAndErrs -> (Maybe Bool, WarnsAndErrs))
    -> LintM Bool
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe Bool, WarnsAndErrs))
     -> LintM Bool)
    -> (LintEnv -> WarnsAndErrs -> (Maybe Bool, WarnsAndErrs))
    -> LintM Bool
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> (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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> 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 }) WarnsAndErrs
    errs ->
        LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m (LintEnv
    env { le_ids :: VarEnv (Var, LintedType)
    le_ids   = VarEnv (Var, LintedType)
    -> Var -> (Var, LintedType) -> VarEnv (Var, LintedType)
    forall a. VarEnv a -> Var -> a -> VarEnv a
    extendVarEnv VarEnv (Var, LintedType)
    id_set Var
    id (Var
    id, LintedType
    linted_ty)
                       , le_joins :: IdSet
    le_joins = IdSet -> IdSet
    add_joins IdSet
    join_set }) WarnsAndErrs
    errs
      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
     -> (Maybe (VarEnv (Var, LintedType)), WarnsAndErrs))
    -> LintM (VarEnv (Var, LintedType))
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\LintEnv
    env WarnsAndErrs
    errs -> (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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs ->
        LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m (LintEnv
    env { le_subst :: TCvSubst
    le_subst = TCvSubst -> Var -> LintedType -> TCvSubst
    Type.extendTvSubst (LintEnv -> TCvSubst
    le_subst LintEnv
    env) Var
    tv LintedType
    ty }) WarnsAndErrs
    errs

    updateTCvSubst :: TCvSubst -> LintM a -> LintM a
    updateTCvSubst :: forall a. TCvSubst -> LintM a -> LintM a
    updateTCvSubst TCvSubst
    subst' LintM a
    m
      = (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m (LintEnv
    env { le_subst :: TCvSubst
    le_subst = TCvSubst
    subst' }) WarnsAndErrs
    errs

    markAllJoinsBad :: LintM a -> LintM a
    markAllJoinsBad :: forall a. LintM a -> LintM a
    markAllJoinsBad LintM a
    m
      = (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a b. (a -> b) -> a -> b
    $ \ LintEnv
    env WarnsAndErrs
    errs -> LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    m (LintEnv
    env { le_joins :: IdSet
    le_joins = IdSet
    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 -> (Maybe IdSet, WarnsAndErrs))
    -> LintM IdSet
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (IdSet -> Maybe IdSet
    forall a. a -> Maybe a
    Just (LintEnv -> IdSet
    le_joins LintEnv
    env), WarnsAndErrs
    errs))

    getTCvSubst :: LintM TCvSubst
    getTCvSubst :: LintM TCvSubst
    getTCvSubst = (LintEnv -> WarnsAndErrs -> (Maybe TCvSubst, WarnsAndErrs))
    -> LintM TCvSubst
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (TCvSubst -> Maybe TCvSubst
    forall a. a -> Maybe a
    Just (LintEnv -> TCvSubst
    le_subst LintEnv
    env), WarnsAndErrs
    errs))

    getUEAliases :: LintM (NameEnv UsageEnv)
    getUEAliases :: LintM (NameEnv UsageEnv)
    getUEAliases = (LintEnv
     -> WarnsAndErrs -> (Maybe (NameEnv UsageEnv), WarnsAndErrs))
    -> LintM (NameEnv UsageEnv)
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (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 -> (Maybe InScopeSet, WarnsAndErrs))
    -> LintM InScopeSet
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM (\ LintEnv
    env WarnsAndErrs
    errs -> (InScopeSet -> Maybe InScopeSet
    forall a. a -> Maybe a
    Just (TCvSubst -> InScopeSet
    getTCvInScope (TCvSubst -> InScopeSet) -> TCvSubst -> InScopeSet
    forall a b. (a -> b) -> a -> b
    $ LintEnv -> TCvSubst
    le_subst LintEnv
    env), WarnsAndErrs
    errs))

    lookupIdInScope :: Id -> LintM (Id, LintedType)
    lookupIdInScope :: Var -> LintM (Var, LintedType)
    lookupIdInScope Var
    id_occ
      = do { VarEnv (Var, LintedType)
    in_scope_ids <- LintM (VarEnv (Var, LintedType))
    getInScopeIds
           ; case VarEnv (Var, LintedType) -> Var -> Maybe (Var, LintedType)
    forall a. VarEnv a -> Var -> Maybe a
    lookupVarEnv VarEnv (Var, LintedType)
    in_scope_ids Var
    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
    global_in_scope
                       ; (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
    text String
    "Out of scope:" SDoc -> SDoc -> SDoc
    <+> BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    id_occ
        global_in_scope :: SDoc
    global_in_scope    = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Occurrence is GlobalId, but binding is LocalId")
                                JoinArity
    2 (BindingSite -> Var -> SDoc
    forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    LetBind Var
    id_occ)
        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 (Maybe JoinArity)
    -- Look up an Id which should be a join point, valid here
    -- If so, return its arity, if not return Nothing
    lookupJoinId :: Var -> LintM (Maybe JoinArity)
    lookupJoinId Var
    id
      = do { IdSet
    join_set <- LintM IdSet
    getValidJoins
           ; case IdSet -> Var -> Maybe Var
    lookupVarSet IdSet
    join_set Var
    id of
                Just Var
    id' -> Maybe JoinArity -> LintM (Maybe JoinArity)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Var -> Maybe JoinArity
    isJoinId_maybe Var
    id')
                Maybe Var
    Nothing  -> Maybe JoinArity -> LintM (Maybe JoinArity)
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe JoinArity
    forall a. Maybe a
    Nothing }

    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 -> (Maybe a, WarnsAndErrs)) -> LintM a
    forall a.
    (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
    LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
    -> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> 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 -> (Maybe a, WarnsAndErrs)
    forall a.
    LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
    unLintM LintM a
    thing_inside (LintEnv
    env { le_ue_aliases :: NameEnv UsageEnv
    le_ue_aliases = NameEnv UsageEnv
    new_ue_aliases }) WarnsAndErrs
    errs

    varCallSiteUsage :: Id -> LintM UsageEnv
    varCallSiteUsage :: Var -> LintM UsageEnv
    varCallSiteUsage Var
    id =
      do NameEnv UsageEnv
    m <- LintM (NameEnv UsageEnv)
    getUEAliases
         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
    $ case NameEnv UsageEnv -> Name -> Maybe UsageEnv
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv NameEnv UsageEnv
    m (Var -> Name
    forall a. NamedThing a => a -> Name
    getName Var
    id) of
             Maybe UsageEnv
    Nothing -> Var -> LintedType -> UsageEnv
    forall n. NamedThing n => n -> LintedType -> UsageEnv
    unitUE Var
    id LintedType
    One
             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
    ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
    ensureEqTys LintedType
    ty1 LintedType
    ty2 SDoc
    msg = Bool -> SDoc -> LintM ()
    lintL (LintedType
    ty1 LintedType -> LintedType -> Bool
    `eqType` LintedType
    ty2) SDoc
    msg

    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
    Many 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_usage LintedType
    described_usage SDoc
    err_msg = do
        LintFlags
    flags <- LintM LintFlags
    getLintFlags
        Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LintFlags -> Bool
    lf_check_linearity LintFlags
    flags) (LintM () -> LintM ()) -> LintM () -> LintM ()
    forall a b. (a -> b) -> a -> b
    $ case LintedType
    actual_usage' LintedType -> LintedType -> IsSubmult
    `submult` LintedType
    described_usage' of
          IsSubmult
    Submult -> () -> LintM ()
    forall a. a -> LintM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          IsSubmult
    Unknown -> case LintedType -> Maybe (LintedType, LintedType)
    isMultMul LintedType
    actual_usage' of
                         Just (LintedType
    m1, LintedType
    m2) -> LintedType -> LintedType -> SDoc -> LintM ()
    ensureSubMult LintedType
    m1 LintedType
    described_usage' SDoc
    err_msg LintM () -> LintM () -> LintM ()
    forall a b. LintM a -> LintM b -> LintM b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
                                          LintedType -> LintedType -> SDoc -> LintM ()
    ensureSubMult LintedType
    m2 LintedType
    described_usage' SDoc
    err_msg
                         Maybe (LintedType, LintedType)
    Nothing -> Bool -> LintM () -> LintM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not (LintedType
    actual_usage' LintedType -> LintedType -> Bool
    `eqType` LintedType
    described_usage')) (SDoc -> LintM ()
    addErrL SDoc
    err_msg)

       where actual_usage' :: LintedType
    actual_usage' = LintedType -> LintedType
    normalize LintedType
    actual_usage
             described_usage' :: LintedType
    described_usage' = LintedType -> LintedType
    normalize LintedType
    described_usage

             normalize :: Mult -> Mult
             normalize :: LintedType -> LintedType
    normalize LintedType
    m = case LintedType -> Maybe (LintedType, LintedType)
    isMultMul LintedType
    m of
                             Just (LintedType
    m1, LintedType
    m2) -> LintedType -> LintedType -> LintedType
    mkMultMul (LintedType -> LintedType
    normalize LintedType
    m1) (LintedType -> LintedType
    normalize LintedType
    m2)
                             Maybe (LintedType, LintedType)
    Nothing -> LintedType
    m

    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
    text String
    "Role incompatibility: expected" SDoc -> SDoc -> SDoc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Role
    r1 SDoc -> SDoc -> SDoc
    <> SDoc
    comma SDoc -> SDoc -> SDoc
    <+>
               String -> SDoc
    text String
    "got" SDoc -> SDoc -> SDoc
    <+> Role -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Role
    r2 SDoc -> SDoc -> SDoc
    $$
               String -> SDoc
    text String
    "in" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "In the RHS of" SDoc -> SDoc -> SDoc
    <+> [Var] -> SDoc
    pp_binders [Var
    v])

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

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

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

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

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

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

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

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

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

    dumpLoc (CaseTy CoreExpr
    scrut)
      = (SrcLoc
    noSrcLoc, SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    text String
    "In the type of a binder:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    b)

    dumpLoc (ImportedUnfolding SrcLoc
    locn)
      = (SrcLoc
    locn, String -> SDoc
    text String
    "In an imported unfolding")
    dumpLoc LintLocInfo
    TopLevelBindings
      = (SrcLoc
    noSrcLoc, SDoc
    Outputable.empty)
    dumpLoc (InType LintedType
    ty)
      = (SrcLoc
    noSrcLoc, String -> SDoc
    text String
    "In the type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty))
    dumpLoc (InCo Coercion
    co)
      = (SrcLoc
    noSrcLoc, String -> SDoc
    text String
    "In the coercion" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co))
    dumpLoc (InAxiom CoAxiom Branched
    ax)
      = (Name -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    getSrcLoc Name
    ax_name, String -> SDoc
    text String
    "In the coercion axiom" SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    ax_name SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> SDoc
    pp_ax)
      where
        CoAxiom { co_ax_name :: forall (br :: BranchFlag). CoAxiom br -> Name
    co_ax_name     = Name
    ax_name
                , co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
    co_ax_tc       = TyCon
    tc
                , co_ax_role :: forall (br :: BranchFlag). CoAxiom br -> Role
    co_ax_role     = Role
    ax_role
                , co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
    co_ax_branches = Branches Branched
    branches } = CoAxiom Branched
    ax
        branch_list :: [CoAxBranch]
    branch_list = Branches Branched -> [CoAxBranch]
    forall (br :: BranchFlag). Branches br -> [CoAxBranch]
    fromBranches Branches Branched
    branches

        pp_ax :: SDoc
    pp_ax
          | [CoAxBranch
    branch] <- [CoAxBranch]
    branch_list
          = CoAxBranch -> SDoc
    pp_branch CoAxBranch
    branch

          | Bool
    otherwise
          = SDoc -> SDoc
    braces (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat ((CoAxBranch -> SDoc) -> [CoAxBranch] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map CoAxBranch -> SDoc
    pp_branch [CoAxBranch]
    branch_list)

        pp_branch :: CoAxBranch -> SDoc
    pp_branch (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_tys
                              , cab_rhs :: CoAxBranch -> LintedType
    cab_rhs = LintedType
    rhs_ty })
          = [SDoc] -> SDoc
    sep [ SDoc -> SDoc
    brackets ((Var -> SDoc) -> [Var] -> SDoc
    forall a. (a -> SDoc) -> [a] -> SDoc
    pprWithCommas Var -> SDoc
    pprTyVar ([Var]
    tvs [Var] -> [Var] -> [Var]
    forall a. [a] -> [a] -> [a]
    ++ [Var]
    cvs)) SDoc -> SDoc -> SDoc
    <> SDoc
    dot
                , LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (TyCon -> [LintedType] -> LintedType
    mkTyConApp TyCon
    tc [LintedType]
    lhs_tys)
                , String -> SDoc
    text String
    "~_" SDoc -> SDoc -> SDoc
    <> Role -> SDoc
    pp_role Role
    ax_role
                , LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    rhs_ty ]

        pp_role :: Role -> SDoc
    pp_role Role
    Nominal          = String -> SDoc
    text String
    "N"
        pp_role Role
    Representational = String -> SDoc
    text String
    "R"
        pp_role Role
    Phantom          = String -> SDoc
    text String
    "P"

    pp_binders :: [Var] -> SDoc
    pp_binders :: [Var] -> SDoc
    pp_binders [Var]
    bs = [SDoc] -> SDoc
    sep (SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    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
    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
    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
    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
    text String
    "Type of case alternatives not the same as the annotation on case:")
             JoinArity
    4 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Actual type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty1,
                       String -> SDoc
    text String
    "Annotation on case:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty2,
                       String -> SDoc
    text String
    "Alt Rhs:" SDoc -> SDoc -> SDoc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e ])

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

    mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc
    mkNonDefltMsg :: CoreExpr -> SDoc
    mkNonDefltMsg CoreExpr
    e
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    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
    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
    vcat [
            String -> SDoc
    text String
    "In a case alternative, data constructor isn't in scrutinee type:",
            String -> SDoc
    text String
    "Scrutinee type constructor:" SDoc -> SDoc -> SDoc
    <+> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tycon,
            String -> SDoc
    text String
    "Data con:" SDoc -> SDoc -> SDoc
    <+> 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
    vcat [
            String -> SDoc
    text String
    "In a case alternative, pattern result type doesn't match scrutinee type:",
            String -> SDoc
    text String
    "Pattern result type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    con_result_ty,
            String -> SDoc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty
        ]

    integerScrutinisedMsg :: SDoc
    integerScrutinisedMsg :: SDoc
    integerScrutinisedMsg
      = String -> SDoc
    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
    vcat [ String -> SDoc
    text String
    "Data alternative when scrutinee is not a tycon application",
               String -> SDoc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty,
               String -> SDoc
    text String
    "Alternative:" SDoc -> SDoc -> SDoc
    <+> 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
    vcat [ String -> SDoc
    text String
    "Data alternative for newtype datacon",
               String -> SDoc
    text String
    "Scrutinee type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    scrut_ty,
               String -> SDoc
    text String
    "Alternative:" SDoc -> SDoc -> SDoc
    <+> 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
    vcat [String -> SDoc
    text String
    "Argument value doesn't match argument type:",
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    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
    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
    vcat [String -> SDoc
    text String
    "Non-function type in function position",
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    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
    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
    vcat [String -> SDoc
    text String
    "Bad `let' binding:",
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Variable:")
                     JoinArity
    4 (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    varType Var
    bndr)),
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    vcat [String -> SDoc
    text String
    "Illegal type application:",
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Exp type:")
                     JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    ty)),
                  SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Arg type:")
                     JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((() :: Constraint) => LintedType -> LintedType
    LintedType -> LintedType
    typeKind LintedType
    arg_ty))]

    emptyRec :: CoreExpr -> SDoc
    emptyRec :: CoreExpr -> SDoc
    emptyRec CoreExpr
    e = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    vcat
        [[SDoc] -> SDoc
    hsep [String -> SDoc
    text String
    "The type of this binder doesn't match the type of its" SDoc -> SDoc -> SDoc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    <> SDoc
    colon,
                Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder],
         [SDoc] -> SDoc
    hsep [String -> SDoc
    text String
    "Binder's type:", LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    idType Var
    binder)],
         [SDoc] -> SDoc
    hsep [String -> SDoc
    text String
    "Rhs type:", LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty]]

    mkLetAppMsg :: CoreExpr -> SDoc
    mkLetAppMsg :: CoreExpr -> SDoc
    mkLetAppMsg CoreExpr
    e
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "This argument does not satisfy the let/app invariant:")
           JoinArity
    2 (CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)

    badBndrTyMsg :: Id -> SDoc -> SDoc
    badBndrTyMsg :: Var -> SDoc -> SDoc
    badBndrTyMsg Var
    binder SDoc
    what
      = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "The type of this binder is" SDoc -> SDoc -> SDoc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    binder
             , String -> SDoc
    text String
    "Binder's type:" SDoc -> SDoc -> SDoc
    <+> 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
    hsep [String -> SDoc
    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
    hsep [String -> SDoc
    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
    hsep [String -> SDoc
    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
    vcat [String -> SDoc
    text String
    "Kinds don't match in type application:",
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Type variable:")
                     JoinArity
    4 (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tyvar SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Var -> LintedType
    tyVarKind Var
    tyvar)),
              SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Arg type:")
                     JoinArity
    4 (LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    arg_ty SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ((() :: Constraint) => 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
    vcat [SDoc
    from_msg SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "of Cast differs from" SDoc -> SDoc -> SDoc
    <+> SDoc
    co_msg
                SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "of" SDoc -> SDoc -> SDoc
    <+> SDoc
    enclosed_msg,
              SDoc
    from_msg SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    from_ty,
              String -> SDoc
    text (String -> String
    capitalise String
    co_str) SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "of" SDoc -> SDoc -> SDoc
    <+> SDoc
    enclosed_msg SDoc -> SDoc -> SDoc
    <> SDoc
    colon
                SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    thing_ty,
              String -> SDoc
    text String
    "Actual" SDoc -> SDoc -> SDoc
    <+> SDoc
    enclosed_msg SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+> SDoc
    pp_thing,
              String -> SDoc
    text String
    "Coercion used in cast:" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    co_str
        from_msg :: SDoc
    from_msg     = String -> SDoc
    text String
    "From-" SDoc -> SDoc -> SDoc
    <> SDoc
    co_msg
        enclosed_msg :: SDoc
    enclosed_msg = String -> SDoc
    text String
    "enclosed" SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    thing_str

    mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
    mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
    mkBadUnivCoMsg LeftOrRight
    lr Coercion
    co
      = String -> SDoc
    text String
    "Kind mismatch on the" SDoc -> SDoc -> SDoc
    <+> LeftOrRight -> SDoc
    pprLeftOrRight LeftOrRight
    lr SDoc -> SDoc -> SDoc
    <+>
        String -> SDoc
    text String
    "side of a UnivCo:" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co

    mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
    mkBadProofIrrelMsg :: LintedType -> Coercion -> SDoc
    mkBadProofIrrelMsg LintedType
    ty Coercion
    co
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Found a non-coercion in a proof-irrelevance UnivCo:")
           JoinArity
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "type:" SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    ty
                   , String -> SDoc
    text String
    "co:" SDoc -> SDoc -> SDoc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co ])

    mkBadTyVarMsg :: Var -> SDoc
    mkBadTyVarMsg :: Var -> SDoc
    mkBadTyVarMsg Var
    tv
      = String -> SDoc
    text String
    "Non-tyvar used in TyVarTy:"
          SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    tv SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> 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
    vcat [ String -> SDoc
    text String
    "Bad join point binding:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var
             , String -> SDoc
    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
    text String
    "Join point has invalid type:")
            JoinArity
    2 (Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> 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
    vcat [ String -> SDoc
    text String
    "Join point has too few lambdas",
               String -> SDoc
    text String
    "Join var:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var,
               String -> SDoc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    ar,
               String -> SDoc
    text String
    "Number of lambdas:" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "Rhs = " SDoc -> SDoc -> SDoc
    <+> CoreExpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    rhs
               ]

    invalidJoinOcc :: Var -> SDoc
    invalidJoinOcc :: Var -> SDoc
    invalidJoinOcc Var
    var
      = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Invalid occurrence of a join variable:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var
             , String -> SDoc
    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
    vcat [ String -> SDoc
    text String
    "Join point invoked with wrong number of arguments",
               String -> SDoc
    text String
    "Join var:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var,
               String -> SDoc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    ar,
               String -> SDoc
    text String
    "Number of arguments:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    int JoinArity
    nargs ]

    mkInconsistentRecMsg :: [Var] -> SDoc
    mkInconsistentRecMsg :: [Var] -> SDoc
    mkInconsistentRecMsg [Var]
    bndrs
      = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Recursive let binders mix values and join points",
               String -> SDoc
    text String
    "Binders:" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    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
    <> 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
    vcat [ String -> SDoc
    text String
    "Mismatch in join point arity between binder and occurrence"
             , String -> SDoc
    text String
    "Var:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr
             , String -> SDoc
    text String
    "Arity at binding site:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    join_arity_bndr
             , String -> SDoc
    text String
    "Arity at occurrence:  " SDoc -> SDoc -> SDoc
    <+> 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
    vcat [ String -> SDoc
    text String
    "Mismatch in type between binder and occurrence"
             , String -> SDoc
    text String
    "Binder:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    bndr_ty
             , String -> SDoc
    text String
    "Occurrence:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    var SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> LintedType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LintedType
    var_ty
             , String -> SDoc
    text String
    "  Before subst:" SDoc -> SDoc -> SDoc
    <+> 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
    vcat [ String -> SDoc
    text String
    "Join point has rule with wrong number of arguments"
             , String -> SDoc
    text String
    "Var:" SDoc -> SDoc -> SDoc
    <+> Var -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Var
    bndr
             , String -> SDoc
    text String
    "Join arity:" SDoc -> SDoc -> SDoc
    <+> JoinArity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr JoinArity
    join_arity
             , String -> SDoc
    text String
    "Rule:" SDoc -> SDoc -> SDoc
    <+> CoreRule -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreRule
    rule ]

    pprLeftOrRight :: LeftOrRight -> SDoc
    pprLeftOrRight :: LeftOrRight -> SDoc
    pprLeftOrRight LeftOrRight
    CLeft  = String -> SDoc
    text String
    "left"
    pprLeftOrRight LeftOrRight
    CRight = String -> SDoc
    text String
    "right"

    dupVars :: [NonEmpty Var] -> SDoc
    dupVars :: [NonEmpty Var] -> SDoc
    dupVars [NonEmpty Var]
    vars
      = SDoc -> JoinArity -> SDoc -> SDoc
    hang (String -> SDoc
    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
    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
      DynFlags
    dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      Logger
    logger <- CoreM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
      Bool -> CoreM () -> CoreM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoAnnotationLinting DynFlags
    dflags) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $
        IO () -> CoreM ()
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ Logger -> String -> IO ()
    Err.showPass Logger
    logger String
    "Annotation linting - first run"
      ModGuts
    nguts <- ModGuts -> CoreM ModGuts
    pass ModGuts
    guts
      -- If appropriate re-run it without debug annotations to make sure
      -- that they made no difference.
      Bool -> CoreM () -> CoreM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoAnnotationLinting DynFlags
    dflags) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ do
        IO () -> CoreM ()
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ Logger -> String -> IO ()
    Err.showPass Logger
    logger String
    "Annotation linting - second run"
        ModGuts
    nguts' <- (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    withoutAnnots ModGuts -> CoreM ModGuts
    pass ModGuts
    guts
        -- Finally compare the resulting bindings
        IO () -> CoreM ()
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ Logger -> String -> IO ()
    Err.showPass Logger
    logger String
    "Annotation linting - comparison"
        let binds :: [(Var, CoreExpr)]
    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' :: [(Var, CoreExpr)]
    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'
            ([SDoc]
    diffs,RnEnv2
    _) = Bool
    -> RnEnv2
    -> [(Var, CoreExpr)]
    -> [(Var, CoreExpr)]
    -> ([SDoc], RnEnv2)
    diffBinds Bool
    True (InScopeSet -> RnEnv2
    mkRnEnv2 InScopeSet
    emptyInScopeSet) [(Var, CoreExpr)]
    binds [(Var, CoreExpr)]
    binds'
        Bool -> CoreM () -> CoreM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not ([SDoc] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [SDoc]
    diffs)) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ SDoc -> CoreM ()
    GHC.Core.Opt.Monad.putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
          [ String -> SDoc -> SDoc
    lint_banner String
    "warning" SDoc
    pname
          , String -> SDoc
    text String
    "Core changes with annotations:"
          , PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ JoinArity -> SDoc -> SDoc
    nest JoinArity
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat [SDoc]
    diffs
          ]
      -- Return actual new guts
      ModGuts -> CoreM ModGuts
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    nguts

    -- | 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.
      DynFlags
    dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      let removeFlag :: HscEnv -> HscEnv
    removeFlag HscEnv
    env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
    DynFlags -> HscEnv -> HscEnv
    hscSetFlags (DynFlags
    dflags { debugLevel :: JoinArity
    debugLevel = JoinArity
    0}) HscEnv
    env
          withoutFlag :: CoreM ModGuts -> CoreM (ModGuts, SimplCount)
    withoutFlag CoreM ModGuts
    corem =
              -- TODO: supply tag here as well ?
            IO (ModGuts, SimplCount) -> CoreM (ModGuts, SimplCount)
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (ModGuts, SimplCount) -> CoreM (ModGuts, SimplCount))
    -> CoreM (IO (ModGuts, SimplCount)) -> CoreM (ModGuts, SimplCount)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> ModuleSet
    -> PrintUnqualified
    -> SrcSpan
    -> CoreM ModGuts
    -> IO (ModGuts, SimplCount)
    forall a.
    HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> ModuleSet
    -> PrintUnqualified
    -> SrcSpan
    -> CoreM a
    -> IO (a, SimplCount)
    runCoreM (HscEnv
     -> RuleBase
     -> Char
     -> Module
     -> ModuleSet
     -> PrintUnqualified
     -> SrcSpan
     -> CoreM ModGuts
     -> IO (ModGuts, SimplCount))
    -> CoreM HscEnv
    -> CoreM
         (RuleBase
          -> Char
          -> Module
          -> ModuleSet
          -> PrintUnqualified
          -> SrcSpan
          -> CoreM ModGuts
          -> IO (ModGuts, SimplCount))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (HscEnv -> HscEnv) -> CoreM HscEnv -> CoreM HscEnv
    forall a b. (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap HscEnv -> HscEnv
    removeFlag CoreM HscEnv
    getHscEnv CoreM
      (RuleBase
       -> Char
       -> Module
       -> ModuleSet
       -> PrintUnqualified
       -> SrcSpan
       -> CoreM ModGuts
       -> IO (ModGuts, SimplCount))
    -> CoreM RuleBase
    -> CoreM
         (Char
          -> Module
          -> ModuleSet
          -> PrintUnqualified
          -> SrcSpan
          -> CoreM ModGuts
          -> IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> CoreM RuleBase
    getRuleBase CoreM
      (Char
       -> Module
       -> ModuleSet
       -> PrintUnqualified
       -> SrcSpan
       -> CoreM ModGuts
       -> IO (ModGuts, SimplCount))
    -> CoreM Char
    -> CoreM
         (Module
          -> ModuleSet
          -> PrintUnqualified
          -> SrcSpan
          -> CoreM ModGuts
          -> IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*>
                                    CoreM Char
    getUniqMask CoreM
      (Module
       -> ModuleSet
       -> PrintUnqualified
       -> SrcSpan
       -> CoreM ModGuts
       -> IO (ModGuts, SimplCount))
    -> CoreM Module
    -> CoreM
         (ModuleSet
          -> PrintUnqualified
          -> SrcSpan
          -> CoreM ModGuts
          -> IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> CoreM Module
    forall (m :: * -> *). HasModule m => m Module
    getModule CoreM
      (ModuleSet
       -> PrintUnqualified
       -> SrcSpan
       -> CoreM ModGuts
       -> IO (ModGuts, SimplCount))
    -> CoreM ModuleSet
    -> CoreM
         (PrintUnqualified
          -> SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*>
                                    CoreM ModuleSet
    getVisibleOrphanMods CoreM
      (PrintUnqualified
       -> SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
    -> CoreM PrintUnqualified
    -> CoreM (SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*>
                                    CoreM PrintUnqualified
    getPrintUnqualified CoreM (SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
    -> CoreM SrcSpan
    -> CoreM (CoreM ModGuts -> IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> CoreM SrcSpan
    getSrcSpanM CoreM (CoreM ModGuts -> IO (ModGuts, SimplCount))
    -> CoreM (CoreM ModGuts) -> CoreM (IO (ModGuts, SimplCount))
    forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*>
                                    CoreM ModGuts -> CoreM (CoreM ModGuts)
    forall a. a -> CoreM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure CoreM ModGuts
    corem
      -- 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 :: CoreProgram
    mg_binds = (Bind Var -> Bind Var) -> CoreProgram -> CoreProgram
    forall a b. (a -> b) -> [a] -> [b]
    map Bind Var -> Bind Var
    nukeAnnotsBind CoreProgram
    binds}
      -- Perform pass with all changes applied
      ((ModGuts, SimplCount) -> ModGuts)
    -> CoreM (ModGuts, SimplCount) -> CoreM ModGuts
    forall a b. (a -> b) -> CoreM a -> CoreM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (ModGuts, SimplCount) -> ModGuts
    forall a b. (a, b) -> a
    fst (CoreM (ModGuts, SimplCount) -> CoreM ModGuts)
    -> CoreM (ModGuts, SimplCount) -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ CoreM ModGuts -> CoreM (ModGuts, SimplCount)
    withoutFlag (CoreM ModGuts -> CoreM (ModGuts, SimplCount))
    -> CoreM ModGuts -> CoreM (ModGuts, SimplCount)
    forall a b. (a -> b) -> a -> b
    $ ModGuts -> CoreM ModGuts
    pass (ModGuts -> ModGuts
    nukeAnnotsMod ModGuts
    guts)