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

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-}

module GHC.Core.Lint (
    lintCoreBindings, lintUnfolding,
    lintPassResult, lintInteractiveExpr, lintExpr,
    lintAnnots, lintTypes,

    -- ** Debug output
    endPass, endPassIO,
    dumpPassResult,
    GHC.Core.Lint.dumpIfSet,
 ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.Stats ( coreBindsStats )
import GHC.Core.Opt.Monad
import GHC.Data.Bag
import GHC.Types.Literal
import GHC.Core.DataCon
import GHC.Builtin.Types.Prim
import GHC.Tc.Utils.TcType ( isFloatingTy )
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.Id
import GHC.Types.Id.Info
import GHC.Core.Ppr
import GHC.Utils.Error
import GHC.Core.Coercion
import GHC.Types.SrcLoc
import GHC.Core.Type as Type
import GHC.Types.RepType
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 )
import GHC.Core.TyCon as TyCon
import GHC.Core.Coercion.Axiom
import GHC.Types.Basic
import GHC.Utils.Error as Err
import GHC.Data.List.SetOps
import GHC.Builtin.Names
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Core.InstEnv      ( instanceDFunId )
import GHC.Core.Coercion.Opt ( checkAxInstCo )
import GHC.Core.Opt.Arity    ( typeArity )
import GHC.Types.Demand      ( splitStrictSig, isDeadEndDiv )

import GHC.Driver.Types
import GHC.Driver.Session
import Control.Monad
import GHC.Utils.Monad
import Data.Foldable      ( toList )
import Data.List.NonEmpty ( NonEmpty )
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)

Outstanding issues:

    -- Things are *not* OK if:
    --
    --  * Unsaturated type app before specialisation has been done;
    --
    --  * Oversaturated type app after specialisation (eta reduction
    --   may well be happening...);


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 [Type let] in CoreSyn.
One place it is used is in mkWwArgs; 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-moduolo-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` becuase 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 subsitution 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 (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type MonadIO CoreM
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 { DynFlags
-> PrintUnqualified
-> Maybe DumpFlag
-> SDoc
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpPassResult DynFlags
dflags PrintUnqualified
print_unqual Maybe DumpFlag
mb_flag
                        (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable CoreToDo
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
    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 | DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags                    -> DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
flag
                          | DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_verbose_core2core DynFlags
dflags -> DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
flag
                Maybe DumpFlag
_ -> Maybe DumpFlag
forall a. Maybe a
Nothing

dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet DynFlags
dflags Bool
dump_me CoreToDo
pass SDoc
extra_info SDoc
doc
  = DynFlags -> Bool -> String -> SDoc -> IO ()
Err.dumpIfSet DynFlags
dflags Bool
dump_me (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable CoreToDo
ppr CoreToDo
pass SDoc -> SDoc -> SDoc
<+> SDoc
extra_info)) SDoc
doc

dumpPassResult :: DynFlags
               -> PrintUnqualified
               -> Maybe DumpFlag        -- Just df => show details in a file whose
                                        --            name is specified by df
               -> SDoc                  -- Header
               -> SDoc                  -- Extra info to appear after header
               -> CoreProgram -> [CoreRule]
               -> IO ()
dumpPassResult :: DynFlags
-> PrintUnqualified
-> Maybe DumpFlag
-> SDoc
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpPassResult DynFlags
dflags PrintUnqualified
unqual Maybe DumpFlag
mb_flag SDoc
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 ()
External instance of the constraint type Monad IO
External instance of the constraint type Foldable Maybe
forM_ Maybe DumpFlag
mb_flag ((DumpFlag -> IO ()) -> IO ()) -> (DumpFlag -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DumpFlag
flag -> do
           let sty :: PprStyle
sty = PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
unqual
           DumpAction
dumpAction DynFlags
dflags PprStyle
sty (DumpFlag -> DumpOptions
dumpOptionsFromFlag DumpFlag
flag)
              (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
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.
       ; DynFlags -> JoinArity -> SDoc -> IO ()
Err.debugTraceMsg DynFlags
dflags JoinArity
2 SDoc
size_doc
       }

  where
    size_doc :: SDoc
size_doc = [SDoc] -> SDoc
sep [String -> SDoc
text String
"Result size of" SDoc -> SDoc -> SDoc
<+> SDoc
hdr, JoinArity -> SDoc -> SDoc
nest JoinArity
2 (SDoc
equals SDoc -> SDoc -> SDoc
<+> CoreStats -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable CoreStats
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
                     , CoreProgram -> SDoc
pprCoreBindingsWithSize CoreProgram
binds
                     , Bool -> SDoc -> SDoc
ppUnless ([CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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
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 (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ()
  | Bool
otherwise
  = do { let (Bag SDoc
warns, Bag SDoc
errs) = DynFlags
-> CoreToDo -> [Var] -> CoreProgram -> (Bag SDoc, Bag SDoc)
lintCoreBindings DynFlags
dflags CoreToDo
pass (HscEnv -> [Var]
interactiveInScope HscEnv
hsc_env) CoreProgram
binds
       ; DynFlags -> String -> IO ()
Err.showPass DynFlags
dflags (String
"Core Linted result of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreToDo -> String
forall a. Outputable a => DynFlags -> a -> String
External instance of the constraint type Outputable CoreToDo
showPpr DynFlags
dflags CoreToDo
pass)
       ; DynFlags
-> CoreToDo -> Bag SDoc -> Bag SDoc -> CoreProgram -> IO ()
displayLintResults DynFlags
dflags CoreToDo
pass Bag SDoc
warns Bag SDoc
errs CoreProgram
binds  }
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

displayLintResults :: DynFlags -> CoreToDo
                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
                   -> IO ()
displayLintResults :: DynFlags
-> CoreToDo -> Bag SDoc -> Bag SDoc -> CoreProgram -> IO ()
displayLintResults DynFlags
dflags CoreToDo
pass Bag SDoc
warns Bag SDoc
errs CoreProgram
binds
  | Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs)
  = do { DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
Err.SevDump SrcSpan
noSrcSpan
           (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
           ([SDoc] -> SDoc
vcat [ String -> SDoc -> SDoc
lint_banner String
"errors" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable CoreToDo
ppr CoreToDo
pass), Bag SDoc -> SDoc
Err.pprMessageBag Bag SDoc
errs
                 , String -> SDoc
text String
"*** Offending Program ***"
                 , CoreProgram -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
External instance of the constraint type OutputableBndr Var
pprCoreBindings CoreProgram
binds
                 , String -> SDoc
text String
"*** End of Offense ***" ])
       ; DynFlags -> JoinArity -> IO ()
Err.ghcExit DynFlags
dflags JoinArity
1 }

  | Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
warns)
  , Bool -> Bool
not (DynFlags -> Bool
hasNoDebugOutput DynFlags
dflags)
  , CoreToDo -> Bool
showLintWarnings CoreToDo
pass
  -- If the Core linter encounters an error, output to stderr instead of
  -- stdout (#13342)
  = DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
Err.SevInfo 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" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable CoreToDo
ppr CoreToDo
pass) 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 (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ()
  where

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 :: String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr String
what HscEnv
hsc_env CoreExpr
expr
  | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCoreLinting DynFlags
dflags)
  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ()
  | Just SDoc
err <- DynFlags -> [Var] -> CoreExpr -> Maybe SDoc
lintExpr DynFlags
dflags (HscEnv -> [Var]
interactiveInScope HscEnv
hsc_env) CoreExpr
expr
  = do { SDoc -> IO ()
display_lint_err SDoc
err
       ; DynFlags -> JoinArity -> IO ()
Err.ghcExit DynFlags
dflags JoinArity
1 }
  | Bool
otherwise
  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ()
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

    display_lint_err :: SDoc -> IO ()
display_lint_err SDoc
err
      = do { DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
Err.SevDump
               SrcSpan
noSrcSpan
               (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
               ([SDoc] -> SDoc
vcat [ String -> SDoc -> SDoc
lint_banner String
"errors" (String -> SDoc
text String
what)
                     , SDoc
err
                     , String -> SDoc
text String
"*** Offending Program ***"
                     , CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
External instance of the constraint type OutputableBndr Var
pprCoreExpr CoreExpr
expr
                     , String -> SDoc
text String
"*** End of Offense ***" ])
           ; DynFlags -> JoinArity -> IO ()
Err.ghcExit DynFlags
dflags JoinArity
1 }

interactiveInScope :: HscEnv -> [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.Driver.Types).
-- 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 :: HscEnv -> [Var]
interactiveInScope HscEnv
hsc_env
  = [Var]
tyvars [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
ids
  where
    -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr
    ictxt :: InteractiveContext
ictxt                   = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
    ([ClsInst]
cls_insts, [FamInst]
_fam_insts) = InteractiveContext -> ([ClsInst], [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]
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 -> (Bag MsgDoc, Bag MsgDoc)
--   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 -> (Bag SDoc, Bag SDoc)
lintCoreBindings DynFlags
dflags CoreToDo
pass [Var]
local_in_scope CoreProgram
binds
  = DynFlags -> LintFlags -> [Var] -> LintM () -> (Bag SDoc, Bag SDoc)
forall a.
DynFlags -> LintFlags -> [Var] -> LintM a -> (Bag SDoc, Bag SDoc)
initL DynFlags
dflags LintFlags
flags [Var]
local_in_scope (LintM () -> (Bag SDoc, Bag SDoc))
-> LintM () -> (Bag SDoc, Bag SDoc)
forall a b. (a -> b) -> a -> b
$
    LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
TopLevelBindings           (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
    do { Bool -> SDoc -> LintM ()
checkL ([NonEmpty Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [NonEmpty Var]
dups) ([NonEmpty Var] -> SDoc
dupVars [NonEmpty Var]
dups)
       ; Bool -> SDoc -> LintM ()
checkL ([NonEmpty Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [NonEmpty Name]
ext_dups) ([NonEmpty Name] -> SDoc
dupExtVars [NonEmpty Name]
ext_dups)
       ; TopLevelFlag -> [(Var, CoreExpr)] -> LintM () -> LintM ()
forall a. TopLevelFlag -> [(Var, CoreExpr)] -> LintM a -> LintM a
lintRecBindings TopLevelFlag
TopLevel [(Var, CoreExpr)]
all_pairs (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
         () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 transformation rules can bring something
     -- into use 'unexpectedly'; see Note [Glomming] in 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 = LintFlags
defaultLintFlags
               { 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 }

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

    ([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
External instance of the constraint type Ord Var
compare [Var]
binders

    -- dups_ext checks for names with different uniques
    -- but 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
External instance of the constraint type forall a b. (Ord a, Ord b) => Ord (a, b)
External instance of the constraint type forall unit. Ord unit => Ord (GenModule unit)
External instance of the constraint type Ord (GenUnit UnitId)
External instance of the constraint type Ord OccName
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 MsgDoc   -- Nothing => OK

lintUnfolding :: Bool -> DynFlags -> SrcLoc -> IdSet -> CoreExpr -> Maybe 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 SDoc
forall a. Maybe a
Nothing
  | Bool
otherwise       = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Bag SDoc -> SDoc
pprMessageBag 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 -> (Bag SDoc, Bag SDoc)
forall a.
DynFlags -> LintFlags -> [Var] -> LintM a -> (Bag SDoc, Bag SDoc)
initL DynFlags
dflags LintFlags
defaultLintFlags [Var]
vars (LintM LintedType -> (Bag SDoc, Bag SDoc))
-> LintM LintedType -> (Bag SDoc, Bag SDoc)
forall a b. (a -> b) -> a -> b
$
                     if Bool
is_compulsory
                       -- See Note [Checking for levity polymorphism]
                     then LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
noLPChecks LintM LintedType
linter
                     else LintM LintedType
linter
    linter :: LintM LintedType
linter = LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (SrcLoc -> LintLocInfo
ImportedUnfolding SrcLoc
locn) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
             CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
expr

lintExpr :: DynFlags
         -> [Var]               -- Treat these as in scope
         -> CoreExpr
         -> Maybe MsgDoc        -- Nothing => OK

lintExpr :: DynFlags -> [Var] -> CoreExpr -> Maybe SDoc
lintExpr DynFlags
dflags [Var]
vars CoreExpr
expr
  | Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs = Maybe SDoc
forall a. Maybe a
Nothing
  | Bool
otherwise       = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Bag SDoc -> SDoc
pprMessageBag Bag SDoc
errs)
  where
    (Bag SDoc
_warns, Bag SDoc
errs) = DynFlags
-> LintFlags -> [Var] -> LintM LintedType -> (Bag SDoc, Bag SDoc)
forall a.
DynFlags -> LintFlags -> [Var] -> LintM a -> (Bag SDoc, Bag SDoc)
initL DynFlags
dflags LintFlags
defaultLintFlags [Var]
vars LintM LintedType
linter
    linter :: LintM LintedType
linter = LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
TopLevelBindings (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
             CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
expr

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

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

lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
                -> LintM a -> LintM a
lintRecBindings :: TopLevelFlag -> [(Var, CoreExpr)] -> LintM a -> LintM a
lintRecBindings TopLevelFlag
top_lvl [(Var, CoreExpr)]
pairs LintM a
thing_inside
  = TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
forall a. TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
lintIdBndrs TopLevelFlag
top_lvl [Var]
bndrs (([Var] -> LintM a) -> LintM a) -> ([Var] -> LintM a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ [Var]
bndrs' ->
    do { (Var -> CoreExpr -> LintM ()) -> [Var] -> [CoreExpr] -> LintM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
Instance of class: Applicative of the constraint type Applicative LintM
zipWithM_ Var -> CoreExpr -> LintM ()
lint_pair [Var]
bndrs' [CoreExpr]
rhss
       ; LintM a
thing_inside }
  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 ()
lint_pair Var
bndr' CoreExpr
rhs
      = LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RhsOf Var
bndr') (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
        do { LintedType
rhs_ty <- Var -> CoreExpr -> LintM LintedType
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 }

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
|| Bool -> Bool
not (HasDebugCallStack => LintedType -> Bool
LintedType -> Bool
External instance of the constraint type HasDebugCallStack
isUnliftedType LintedType
binder_ty)
               Bool -> Bool -> Bool
|| (RecFlag -> Bool
isNonRec RecFlag
rec_flag Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)
               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 top-level or recursive, it's not
        -- demanded. Primitive string literals are exempt as there is no
        -- computation to perform, see Note [Core top-level string literals].
       ; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Var -> Bool
isStrictId Var
binder)
            Bool -> Bool -> Bool
|| (RecFlag -> Bool
isNonRec RecFlag
rec_flag Bool -> Bool -> Bool
&& Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl))
            Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
rhs)
           (Var -> SDoc
mkStrictMsg Var
binder)

        -- 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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Var
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
External instance of the constraint type Outputable JoinArity
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
External instance of the constraint type Outputable JoinArity
ppr ([OneShotInfo] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
External instance of the constraint type Foldable []
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
External instance of the constraint type Outputable Var
ppr Var
binder)

       ; case StrictSig -> ([Demand], Divergence)
splitStrictSig (Var -> StrictSig
idStrictness 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
External instance of the constraint type Outputable JoinArity
ppr (Var -> JoinArity
idArity Var
binder) SDoc -> SDoc -> SDoc
<+>
               String -> SDoc
text String
"exceeds arity imposed by the strictness signature" SDoc -> SDoc -> SDoc
<+>
               StrictSig -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable StrictSig
ppr (Var -> StrictSig
idStrictness Var
binder) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
               Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
binder)
           ([Demand], Divergence)
_ -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 ()
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
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) }

        -- 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
-- NB: the Id can be Linted or not -- it's only used for
--     its OccInfo and join-pointer-hood
lintRhs :: Var -> CoreExpr -> LintM LintedType
lintRhs Var
bndr CoreExpr
rhs
    | Just JoinArity
arity <- Var -> Maybe JoinArity
isJoinId_maybe Var
bndr
    = JoinArity -> JoinArity -> Bool -> CoreExpr -> LintM LintedType
lint_join_lams JoinArity
arity JoinArity
arity Bool
True CoreExpr
rhs
    | AlwaysTailCalled JoinArity
arity <- OccInfo -> TailCallInfo
tailCallInfo (Var -> OccInfo
idOccInfo Var
bndr)
    = JoinArity -> JoinArity -> Bool -> CoreExpr -> LintM LintedType
lint_join_lams JoinArity
arity JoinArity
arity Bool
False CoreExpr
rhs
  where
    lint_join_lams :: JoinArity -> JoinArity -> Bool -> CoreExpr -> LintM LintedType
lint_join_lams JoinArity
0 JoinArity
_ Bool
_ CoreExpr
rhs
      = CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
rhs

    lint_join_lams JoinArity
n JoinArity
tot Bool
enforce (Lam Var
var CoreExpr
expr)
      = Var -> LintM LintedType -> LintM LintedType
lintLambda Var
var (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ JoinArity -> JoinArity -> Bool -> CoreExpr -> LintM LintedType
lint_join_lams (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
External instance of the constraint type Num JoinArity
-JoinArity
1) JoinArity
tot Bool
enforce CoreExpr
expr

    lint_join_lams JoinArity
n JoinArity
tot Bool
True CoreExpr
_other
      = SDoc -> LintM LintedType
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM LintedType) -> SDoc -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ Var -> JoinArity -> JoinArity -> CoreExpr -> SDoc
mkBadJoinArityMsg Var
bndr JoinArity
tot (JoinArity
totJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
External instance of the constraint type Num JoinArity
-JoinArity
n) CoreExpr
rhs
    lint_join_lams JoinArity
_ JoinArity
_ Bool
False CoreExpr
rhs
      = LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
rhs
          -- Future join point, not yet eta-expanded
          -- Body is not a tail position

-- 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor LintM
fmap LintFlags -> StaticPtrCheck
lf_check_static_ptrs LintM LintFlags
getLintFlags LintM StaticPtrCheck
-> (StaticPtrCheck -> LintM LintedType) -> LintM LintedType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
Instance of class: Monad of the constraint type Monad LintM
>>= StaticPtrCheck -> LintM LintedType
go
  where
    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
    -- otherwise.
    go :: StaticPtrCheck -> LintM LintedType
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 -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
        (Var -> LintM LintedType -> LintM LintedType)
-> LintM LintedType -> [Var] -> LintM LintedType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr
        -- imitate @lintCoreExpr (Lam ...)@
        Var -> LintM LintedType -> LintM LintedType
lintLambda
        -- imitate @lintCoreExpr (App ...)@
        (do LintedType
fun_ty <- CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
fun
            LintedType -> [CoreExpr] -> LintM LintedType
lintCoreArgs LintedType
fun_ty [LintedType -> CoreExpr
forall b. LintedType -> Expr b
Type LintedType
t, CoreExpr
info, CoreExpr
e]
        )
        [Var]
binders0
    go StaticPtrCheck
_ = LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
rhs

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 <- if Unfolding -> Bool
isCompulsoryUnfolding Unfolding
uf
               then LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
noLPChecks (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ Var -> CoreExpr -> LintM LintedType
lintRhs Var
bndr CoreExpr
rhs
                     -- See Note [Checking for levity polymorphism]
               else Var -> CoreExpr -> LintM LintedType
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 levity polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We ordinarily want to check for bad levity polymorphism. See
Note [Levity 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 levity-polymorphic;
indeed levity-polyorphic unfoldings are a primary reason for the
very existence of compulsory unfoldings (we can't compile code for
the original, levity-poly, binding).

It is vitally important that we do levity-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.

************************************************************************
*                                                                      *
\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

lintCoreExpr :: CoreExpr -> LintM LintedType
-- 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
lintCoreExpr (Var Var
var)
  = Var -> JoinArity -> LintM LintedType
lintIdOcc Var
var JoinArity
0

lintCoreExpr (Lit Literal
lit)
  = LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Literal -> LintedType
literalType Literal
lit)

lintCoreExpr (Cast CoreExpr
expr Coercion
co)
  = do { LintedType
expr_ty <- LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
expr
       ; 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
External instance of the constraint type Outputable Coercion
ppr Coercion
co')
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return LintedType
to_ty }

lintCoreExpr (Tick Tickish Var
tickish CoreExpr
expr)
  = do case Tickish Var
tickish of
         Breakpoint JoinArity
_ [Var]
ids -> [Var] -> (Var -> LintM (Var, LintedType)) -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
forM_ [Var]
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
         Tickish Var
_                -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return ()
       Bool -> LintM LintedType -> LintM LintedType
forall a. Bool -> LintM a -> LintM a
markAllJoinsBadIf Bool
block_joins (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
expr
  where
    block_joins :: Bool
block_joins = Bool -> Bool
not (Tickish Var
tickish Tickish Var -> TickishScoping -> Bool
forall id. Tickish id -> 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) -> LintM LintedType
forall a. Var -> (Var -> LintM a) -> LintM a
lintTyBndr Var
tv              ((Var -> LintM LintedType) -> LintM LintedType)
-> (Var -> LintM LintedType) -> LintM LintedType
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 -> LintM LintedType
forall a. Var -> LintedType -> LintM a -> LintM a
extendTvSubstL Var
tv LintedType
ty'        (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
          LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var
tv]) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> LintM LintedType
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 <- Var -> CoreExpr -> LintM LintedType
lintRhs Var
bndr CoreExpr
rhs

         -- Now lint the binder
       ; BindingSite -> Var -> (Var -> LintM LintedType) -> LintM LintedType
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
LetBind Var
bndr ((Var -> LintM LintedType) -> LintM LintedType)
-> (Var -> LintM LintedType) -> LintM LintedType
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
       ; LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var
bndr]) (CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
body) } }

  | Bool
otherwise
  = SDoc -> LintM LintedType
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 (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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
External instance of the constraint type Ord Var
compare [Var]
bndrs
        ; Bool -> SDoc -> LintM ()
checkL ([NonEmpty Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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
External instance of the constraint type Foldable []
all Var -> Bool
isJoinId [Var]
bndrs Bool -> Bool -> Bool
|| (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
External instance of the constraint type Foldable []
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

        ; TopLevelFlag
-> [(Var, CoreExpr)] -> LintM LintedType -> LintM LintedType
forall a. TopLevelFlag -> [(Var, CoreExpr)] -> LintM a -> LintM a
lintRecBindings TopLevelFlag
NotTopLevel [(Var, CoreExpr)]
pairs (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
          LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var]
bndrs)       (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
body }
  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
_)
  = do { LintedType
fun_ty <- CoreExpr -> JoinArity -> LintM LintedType
lintCoreFun CoreExpr
fun ([CoreExpr] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
External instance of the constraint type Foldable []
length [CoreExpr]
args)
       ; LintedType -> [CoreExpr] -> LintM LintedType
lintCoreArgs LintedType
fun_ty [CoreExpr]
args }
  where
    (CoreExpr
fun, [CoreExpr]
args) = CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e

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

lintCoreExpr (Case CoreExpr
scrut Var
var LintedType
alt_ty [Alt Var]
alts)
  = CoreExpr -> Var -> LintedType -> [Alt Var] -> LintM LintedType
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
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
External instance of the constraint type Outputable LintedType
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 -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Coercion -> LintedType
coercionType Coercion
co') }

----------------------
lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed
           -> LintM LintedType -- returns type of the *variable*
lintIdOcc :: Var -> JoinArity -> LintM LintedType
lintIdOcc Var
var JoinArity
nargs
  = LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
OccOf Var
var) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
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
External instance of the constraint type Outputable Var
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
when (JoinArity
nargs JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq JoinArity
/= JoinArity
0 Bool -> Bool -> Bool
&& LintFlags -> StaticPtrCheck
lf_check_static_ptrs LintFlags
lf StaticPtrCheck -> StaticPtrCheck -> Bool
forall a. Eq a => a -> a -> Bool
Instance of class: Eq of the constraint type Eq StaticPtrCheck
/= 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
External instance of the constraint type Eq Name
/= 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

        ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return LintedType
linted_bndr_ty }

lintCoreFun :: CoreExpr
            -> Int              -- Number of arguments (type or val) being passed
            -> LintM LintedType -- Returns type of the *function*
lintCoreFun :: CoreExpr -> JoinArity -> LintM LintedType
lintCoreFun (Var Var
var) JoinArity
nargs
  = Var -> JoinArity -> LintM LintedType
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
External instance of the constraint type Eq JoinArity
/= JoinArity
0
  = Var -> LintM LintedType -> LintM LintedType
lintLambda Var
var (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> JoinArity -> LintM LintedType
lintCoreFun CoreExpr
body (JoinArity
nargs JoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
External instance of the constraint type Num JoinArity
- JoinArity
1)

lintCoreFun CoreExpr
expr JoinArity
nargs
  = Bool -> LintM LintedType -> LintM LintedType
forall a. Bool -> LintM a -> LintM a
markAllJoinsBadIf (JoinArity
nargs JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq JoinArity
/= JoinArity
0) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
      -- See Note [Join points are less general than the paper]
    CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
expr
------------------
lintLambda :: Var -> LintM Type -> LintM Type
lintLambda :: Var -> LintM LintedType -> LintM LintedType
lintLambda Var
var LintM LintedType
lintBody =
    LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
LambdaBodyOf Var
var) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
    BindingSite -> Var -> (Var -> LintM LintedType) -> LintM LintedType
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
LambdaBind Var
var ((Var -> LintM LintedType) -> LintM LintedType)
-> (Var -> LintM LintedType) -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ \ Var
var' ->
      do { LintedType
body_ty <- LintM LintedType
lintBody
         ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Var -> LintedType -> LintedType
mkLamType Var
var' LintedType
body_ty) }
------------------
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
External instance of the constraint type Outputable Var
ppr Var
id) }
  | Bool
otherwise
  = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type forall a. Outputable a => Outputable (UniqSet a)
External instance of the constraint type Outputable Var
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
External instance of the constraint type Eq JoinArity
== 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
External instance of the constraint type Eq JoinArity
== 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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return ()

{-
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 -> [CoreArg] -> LintM LintedType
lintCoreArgs :: LintedType -> [CoreExpr] -> LintM LintedType
lintCoreArgs LintedType
fun_ty [CoreExpr]
args = (LintedType -> CoreExpr -> LintM LintedType)
-> LintedType -> [CoreExpr] -> LintM LintedType
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
foldM LintedType -> CoreExpr -> LintM LintedType
lintCoreArg LintedType
fun_ty [CoreExpr]
args

lintCoreArg  :: LintedType -> CoreArg -> LintM LintedType
lintCoreArg :: LintedType -> CoreExpr -> LintM LintedType
lintCoreArg LintedType
fun_ty (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
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_ty)
       ; LintedType
arg_ty' <- LintedType -> LintM LintedType
lintType LintedType
arg_ty
       ; LintedType -> LintedType -> LintM LintedType
lintTyApp LintedType
fun_ty LintedType
arg_ty' }

lintCoreArg LintedType
fun_ty CoreExpr
arg
  = do { LintedType
arg_ty <- LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
arg
           -- See Note [Levity polymorphism invariants] in GHC.Core
       ; LintFlags
flags <- LintM LintFlags
getLintFlags
       ; Bool -> SDoc -> LintM ()
lintL (Bool -> Bool
not (LintFlags -> Bool
lf_check_levity_poly LintFlags
flags) Bool -> Bool -> Bool
|| Bool -> Bool
not (LintedType -> Bool
isTypeLevPoly LintedType
arg_ty))
           (String -> SDoc
text String
"Levity-polymorphic argument:" SDoc -> SDoc -> SDoc
<+>
             (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
arg SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
arg_ty))))
          -- check for levity polymorphism first, because otherwise isUnliftedType panics

       ; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (HasDebugCallStack => LintedType -> Bool
LintedType -> Bool
External instance of the constraint type HasDebugCallStack
isUnliftedType LintedType
arg_ty) Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprOkForSpeculation CoreExpr
arg)
                (CoreExpr -> SDoc
mkLetAppMsg CoreExpr
arg)

       ; CoreExpr -> LintedType -> LintedType -> LintM LintedType
lintValApp CoreExpr
arg LintedType
fun_ty LintedType
arg_ty }

-----------------
lintAltBinders :: LintedType     -- Scrutinee type
               -> LintedType     -- Constructor type
               -> [OutVar]    -- Binders
               -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintAltBinders :: LintedType -> LintedType -> [Var] -> LintM ()
lintAltBinders LintedType
scrut_ty LintedType
con_ty []
  = LintedType -> LintedType -> SDoc -> LintM ()
ensureEqTys LintedType
con_ty LintedType
scrut_ty (LintedType -> LintedType -> SDoc
mkBadPatMsg LintedType
con_ty LintedType
scrut_ty)
lintAltBinders LintedType
scrut_ty LintedType
con_ty (Var
bndr:[Var]
bndrs)
  | Var -> Bool
isTyVar Var
bndr
  = do { LintedType
con_ty' <- LintedType -> LintedType -> LintM LintedType
lintTyApp LintedType
con_ty (Var -> LintedType
mkTyVarTy Var
bndr)
       ; LintedType -> LintedType -> [Var] -> LintM ()
lintAltBinders LintedType
scrut_ty LintedType
con_ty' [Var]
bndrs }
  | Bool
otherwise
  = do { LintedType
con_ty' <- CoreExpr -> LintedType -> LintedType -> LintM LintedType
lintValApp (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
bndr) LintedType
con_ty (Var -> LintedType
idType Var
bndr)
       ; LintedType -> LintedType -> [Var] -> LintM ()
lintAltBinders LintedType
scrut_ty LintedType
con_ty' [Var]
bndrs }

-----------------
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)
splitForAllTy_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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 :: CoreExpr -> LintedType -> LintedType -> LintM LintedType
lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType
lintValApp CoreExpr
arg LintedType
fun_ty LintedType
arg_ty
  | Just (LintedType
arg,LintedType
res) <- LintedType -> Maybe (LintedType, LintedType)
splitFunTy_maybe LintedType
fun_ty
  = do { LintedType -> LintedType -> SDoc -> LintM ()
ensureEqTys LintedType
arg LintedType
arg_ty SDoc
err1
       ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return LintedType
res }
  | Bool
otherwise
  = SDoc -> LintM LintedType
forall a. SDoc -> LintM a
failWithL SDoc
err2
  where
    err1 :: SDoc
err1 = LintedType -> LintedType -> CoreExpr -> SDoc
mkAppMsg       LintedType
fun_ty LintedType
arg_ty CoreExpr
arg
    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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_kind))
  where
    tyvar_kind :: LintedType
tyvar_kind = Var -> LintedType
tyVarKind Var
tyvar
    arg_kind :: LintedType
arg_kind = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
arg_ty

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

lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM LintedType
lintCaseExpr :: CoreExpr -> Var -> LintedType -> [Alt Var] -> LintM LintedType
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 <- LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
lintCoreExpr CoreExpr
scrut
          -- See Note [Join points are less general than the paper]
          -- in GHC.Core

     ; 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 :: (AltCon, b, c) -> Bool
isLitPat (LitAlt Literal
_, b
_ , c
_) = Bool
True
           isLitPat (AltCon, b, c)
_                 = Bool
False
     ; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LintedType -> Bool
isFloatingTy LintedType
scrut_ty Bool -> Bool -> Bool
&& (Alt Var -> Bool) -> [Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
External instance of the constraint type Foldable []
any Alt Var -> Bool
forall {b} {c}. (AltCon, b, c) -> Bool
isLitPat [Alt Var]
alts)
         (PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ String
"Lint warning: Scrutinising floating-point " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
"expression with literal pattern in case " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
"analysis (see #9238).")
          SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"scrut" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
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 (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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
External instance of the constraint type Outputable Var
ppr Var
var SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return ()
         Maybe TyCon
_otherwise -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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) -> LintM LintedType
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
CaseBind Var
var ((Var -> LintM LintedType) -> LintM LintedType)
-> (Var -> LintM LintedType) -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ \Var
_ ->
       do { -- Check the alternatives
            (Alt Var -> LintM ()) -> [Alt Var] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
mapM_ (LintedType -> LintedType -> Alt Var -> LintM ()
lintCoreAlt LintedType
scrut_ty LintedType
alt_ty) [Alt Var]
alts
          ; CoreExpr -> LintedType -> [Alt Var] -> LintM ()
checkCaseAlts CoreExpr
e LintedType
scrut_ty [Alt Var]
alts
          ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return LintedType
alt_ty } }

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
External instance of the constraint type Foldable []
all Alt Var -> Bool
forall {b} {c}. (AltCon, b, c) -> 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} {b}. [(AltCon, a, b)] -> 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 (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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 a b. [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault [Alt Var]
alts

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

    non_deflt :: (AltCon, b, c) -> Bool
non_deflt (AltCon
DEFAULT, b
_, c
_) = Bool
False
    non_deflt (AltCon, b, c)
_               = 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 ()
lintAltExpr :: CoreExpr -> LintedType -> LintM ()
lintAltExpr CoreExpr
expr LintedType
ann_ty
  = do { LintedType
actual_ty <- CoreExpr -> LintM LintedType
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) }
         -- See GHC.Core Note [Case expression invariants] item (6)

lintCoreAlt :: LintedType          -- Type of scrutinee
            -> LintedType          -- Type of the alternative
            -> CoreAlt
            -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintCoreAlt :: LintedType -> LintedType -> Alt Var -> LintM ()
lintCoreAlt LintedType
_ LintedType
alt_ty (AltCon
DEFAULT, [Var]
args, CoreExpr
rhs) =
  do { Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [Var]
args) ([Var] -> SDoc
mkDefaultArgsMsg [Var]
args)
     ; CoreExpr -> LintedType -> LintM ()
lintAltExpr CoreExpr
rhs LintedType
alt_ty }

lintCoreAlt LintedType
scrut_ty LintedType
alt_ty (LitAlt Literal
lit, [Var]
args, CoreExpr
rhs)
  | Literal -> Bool
litIsLifted Literal
lit
  = SDoc -> LintM ()
forall a. SDoc -> LintM a
failWithL SDoc
integerScrutinisedMsg
  | Bool
otherwise
  = do { Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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 ()
lintAltExpr CoreExpr
rhs LintedType
alt_ty }
  where
    lit_ty :: LintedType
lit_ty = Literal -> LintedType
literalType Literal
lit

lintCoreAlt LintedType
scrut_ty LintedType
alt_ty alt :: Alt Var
alt@(DataAlt DataCon
con, [Var]
args, CoreExpr
rhs)
  | TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
con)
  = SDoc -> LintM ()
addErrL (LintedType -> Alt Var -> SDoc
mkNewTyDataConAltMsg LintedType
scrut_ty Alt Var
alt)
  | Just (TyCon
tycon, [LintedType]
tycon_arg_tys) <- HasDebugCallStack => LintedType -> Maybe (TyCon, [LintedType])
LintedType -> Maybe (TyCon, [LintedType])
External instance of the constraint type HasDebugCallStack
splitTyConApp_maybe LintedType
scrut_ty
  = LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Alt Var -> LintLocInfo
CaseAlt Alt Var
alt) (LintM () -> LintM ()) -> LintM () -> LintM ()
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
External instance of the constraint type Eq TyCon
== DataCon -> TyCon
dataConTyCon DataCon
con) (TyCon -> DataCon -> SDoc
mkBadConMsg TyCon
tycon DataCon
con)
    ; let con_payload_ty :: LintedType
con_payload_ty = HasDebugCallStack => LintedType -> [LintedType] -> LintedType
LintedType -> [LintedType] -> LintedType
External instance of the constraint type HasDebugCallStack
piResultTys (DataCon -> LintedType
dataConRepType DataCon
con) [LintedType]
tycon_arg_tys

        -- And now bring the new binders into scope
    ; BindingSite -> [Var] -> ([Var] -> LintM ()) -> LintM ()
forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
CasePatBind [Var]
args (([Var] -> LintM ()) -> LintM ())
-> ([Var] -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \ [Var]
args' -> do
    { LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Alt Var -> LintLocInfo
CasePat Alt Var
alt) (LintedType -> LintedType -> [Var] -> LintM ()
lintAltBinders LintedType
scrut_ty LintedType
con_payload_ty [Var]
args')
    ; CoreExpr -> LintedType -> LintM ()
lintAltExpr CoreExpr
rhs LintedType
alt_ty } }

  | Bool
otherwise   -- Scrut-ty is wrong shape
  = SDoc -> LintM ()
addErrL (LintedType -> Alt Var -> SDoc
mkBadAltMsg LintedType
scrut_ty Alt Var
alt)

{-
************************************************************************
*                                                                      *
\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 :: 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 :: 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 :: 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 :: 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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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 :: 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 :: TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintIdBndr TopLevelFlag
top_lvl BindingSite
bind_site Var
id Var -> LintM a
thing_inside
  = ASSERT2( isId id, ppr id )
    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
External instance of the constraint type Outputable Var
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 [Levity polymorphism invariants] in GHC.Core
       ; Bool -> SDoc -> LintM ()
lintL (Var -> Bool
isJoinId Var
id Bool -> Bool -> Bool
|| Bool -> Bool
not (LintFlags -> Bool
lf_check_levity_poly LintFlags
flags)
                Bool -> Bool -> Bool
|| Bool -> Bool
not (LintedType -> Bool
isTypeLevPoly LintedType
id_ty)) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
         String -> SDoc
text String
"Levity-polymorphic binder:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
            SDoc -> SDoc
parens (LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
id_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Var
ppr Var
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
%*                                                                      *
%************************************************************************
-}

lintTypes :: DynFlags
          -> [TyCoVar]   -- Treat these as in scope
          -> [Type]
          -> Maybe MsgDoc -- Nothing => OK
lintTypes :: DynFlags -> [Var] -> [LintedType] -> Maybe SDoc
lintTypes DynFlags
dflags [Var]
vars [LintedType]
tys
  | Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs = Maybe SDoc
forall a. Maybe a
Nothing
  | Bool
otherwise       = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Bag SDoc -> SDoc
pprMessageBag Bag SDoc
errs)
  where
    (Bag SDoc
_warns, Bag SDoc
errs) = DynFlags -> LintFlags -> [Var] -> LintM () -> (Bag SDoc, Bag SDoc)
forall a.
DynFlags -> LintFlags -> [Var] -> LintM a -> (Bag SDoc, Bag SDoc)
initL DynFlags
dflags LintFlags
defaultLintFlags [Var]
vars LintM ()
linter
    linter :: LintM ()
linter = BindingSite -> [Var] -> ([Var] -> LintM ()) -> LintM ()
forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
LambdaBind [Var]
vars (([Var] -> LintM ()) -> LintM ())
-> ([Var] -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \[Var]
_ ->
             (LintedType -> LintM LintedType) -> [LintedType] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
mapM_ LintedType -> LintM LintedType
lintType [LintedType]
tys

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 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
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
External instance of the constraint type Outputable LintedType
ppr LintedType
ty)
             JoinArity
2 (String -> SDoc
text String
"has kind:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
sk)
        ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable TyCon
ppr TyCon
tc)

-------------------
lintType :: LintedType -> 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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type OutputableBndr Var
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
External instance of the constraint type Outputable LintedType
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 (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
t1') [LintedType
t2']
       ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
Instance of class: Functor of the constraint type Functor LintM
<$> 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
4
    -- 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
External instance of the constraint type Outputable LintedType
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)
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Traversable []
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
t1 LintedType
t2)
  = do { LintedType
t1' <- LintedType -> LintM LintedType
lintType LintedType
t1
       ; LintedType
t2' <- LintedType -> LintM LintedType
lintType LintedType
t2
       ; SDoc -> 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
External instance of the constraint type Outputable LintedType
ppr LintedType
ty)) LintedType
t1' LintedType
t2'
       ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (AnonArgFlag -> LintedType -> LintedType -> LintedType
FunTy AnonArgFlag
af 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
External instance of the constraint type Outputable LintedType
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Var
ppr Var
tcv SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (VarBndr Var ArgFlag -> LintedType -> LintedType
ForAllTy (Var -> ArgFlag -> VarBndr Var ArgFlag
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable LintedType
ppr LintedType
body_ty)

         -- For type variables, check for skolem escape
         -- See Note [Phantom type variables in kinds] in GHC.Core.Type
         -- The kind of (forall cv. th) is liftedTypeKind, so no
         -- need to check for skolem-escape in the CoVar case
       ; let body_kind :: LintedType
body_kind = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
body_ty
       ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Var
ppr Var
tcv
                                 , String -> SDoc
text String
"type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
body_ty
                                 , String -> SDoc
text String
"kind:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable LintedType
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 (HasCallStack => 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)
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Traversable []
mapM LintedType -> LintM LintedType
lintType [LintedType]
tys)

       ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return () }

       ; LintedType -> LintedType -> [LintedType] -> LintM ()
lint_ty_app LintedType
ty (TyCon -> LintedType
tyConKind TyCon
tc) [LintedType]
tys'
       ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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)
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Traversable []
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (TyCon -> [LintedType] -> LintedType
TyConApp TyCon
tc [LintedType]
tys') }

-----------------
-- Confirms that a type is really *, #, Constraint etc
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-*-like kind when *-like expected:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
kind SDoc -> SDoc -> SDoc
$$
           String -> SDoc
text String
"when checking" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
  where
    kind :: LintedType
kind = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
ty

-----------------
lintArrow :: SDoc -> LintedType -> LintedType -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintArrow :: SDoc -> LintedType -> LintedType -> LintM ()
lintArrow SDoc
what LintedType
t1 LintedType
t2   -- Eg lintArrow "type or kind `blah'" k1 k2
                       -- or lintArrow "coercion `blah'" k1 k2
  = do { Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
unless (LintedType -> Bool
classifiesTypeWithValues LintedType
k1) (SDoc -> LintM ()
addErrL (SDoc -> LintedType -> SDoc
forall {a}. Outputable a => SDoc -> a -> SDoc
External instance of the constraint type Outputable LintedType
msg (String -> SDoc
text String
"argument") LintedType
k1))
       ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
unless (LintedType -> Bool
classifiesTypeWithValues LintedType
k2) (SDoc -> LintM ()
addErrL (SDoc -> LintedType -> SDoc
forall {a}. Outputable a => SDoc -> a -> SDoc
External instance of the constraint type Outputable LintedType
msg (String -> SDoc
text String
"result")   LintedType
k2)) }
  where
    k1 :: LintedType
k1 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
t1
    k2 :: LintedType
k2 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
t2
    msg :: SDoc -> a -> SDoc
msg SDoc
ar a
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
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
Evidence bound by a type signature of the constraint type Outputable a
ppr a
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
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Ord Integer
>= Integer
0    = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
foldlM (InScopeSet -> LintedType -> LintedType -> LintM LintedType
go_app InScopeSet
in_scope) LintedType
kfn [LintedType]
arg_tys
         ; () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable LintedType
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
kfa LintedType
kfb) LintedType
ta
      = do { let ka :: LintedType
ka = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
ta
           ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable LintedType
ppr LintedType
fun_kind SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ta SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ka)))
           ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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      = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
ta
           ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Var
ppr Var
kv SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
kv_kind SDoc -> SDoc -> SDoc
$$
                                                    LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ta SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ka)))
           ; LintedType -> LintM LintedType
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (LintedType -> LintM LintedType) -> LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ HasCallStack => 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
External instance of the constraint type Outputable LintedType
ppr LintedType
kfn SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ta)))

{- *********************************************************************
*                                                                      *
        Linting rules
*                                                                      *
********************************************************************* -}

lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM ()
lintCoreRule :: Var -> LintedType -> CoreRule -> LintM ()
lintCoreRule Var
_ LintedType
_ (BuiltinRule {})
  = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 <- LintedType -> [CoreExpr] -> LintM LintedType
lintCoreArgs LintedType
fun_ty [CoreExpr]
args
       ; LintedType
rhs_ty <- 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
lintCoreExpr CoreExpr
rhs }
                     Maybe JoinArity
_ -> LintM LintedType -> LintM LintedType
forall a. LintM a -> LintM a
markAllJoinsBad (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM LintedType
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
External instance of the constraint type Outputable LintedType
ppr LintedType
lhs_ty
                            , String -> SDoc
text String
"rhs type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
rhs_ty
                            , String -> SDoc
text String
"fun_ty:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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 (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Var
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 [Rules and join points] in 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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable Coercion
ppr Coercion
g)
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
g Role
Nominal (Coercion -> Role
coercionRole Coercion
g)
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Var
ppr Var
cv)
                  JoinArity
2 (String -> SDoc
text String
"With offending type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return Coercion
linted_co ;
           Maybe Coercion
Nothing -> -- 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
External instance of the constraint type OutputableBndr Var
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
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
External instance of the constraint type Outputable Coercion
ppr Coercion
co)
            JoinArity
2 ([SDoc] -> SDoc
vcat [LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ty', LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
tk, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
tl])
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co' Role
Nominal (Coercion -> Role
coercionRole Coercion
co')
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Uniquable TyCon
`hasKey` Unique
funTyConKey
  , [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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable Coercion
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)
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Traversable []
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
zipWithM_ (Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co) (Role -> TyCon -> [Role]
tyConRolesX Role
r TyCon
tc) [Role]
co_roles
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable Coercion
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 (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
lk1) [LintedType
lk2]
       ; Coercion -> LintedType -> [LintedType] -> LintM ()
lint_co_app Coercion
co (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
rk1) [LintedType
rk2]

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

       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable Coercion
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Coercion
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Var -> Coercion -> Coercion -> Coercion
ForAllCo Var
tcv' Coercion
kind_co' Coercion
body_co') } }

lintCoercion co :: Coercion
co@(FunCo Role
r Coercion
co1 Coercion
co2)
  = do { Coercion
co1' <- Coercion -> LintM Coercion
lintCoercion Coercion
co1
       ; Coercion
co2' <- Coercion -> LintM Coercion
lintCoercion Coercion
co2
       ; let Pair LintedType
lt1 LintedType
rt1 = Coercion -> Pair LintedType
coercionKind Coercion
co1
             Pair LintedType
lt2 LintedType
rt2 = Coercion -> Pair LintedType
coercionKind Coercion
co2
       ; SDoc -> LintedType -> LintedType -> LintM ()
lintArrow (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Coercion
ppr Coercion
co)) LintedType
lt1 LintedType
lt2
       ; SDoc -> LintedType -> LintedType -> LintM ()
lintArrow (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Coercion
ppr Coercion
co)) LintedType
rt1 LintedType
rt2
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co1 Role
r (Coercion -> Role
coercionRole Coercion
co1)
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co2 Role
r (Coercion -> Role
coercionRole Coercion
co2)
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Role -> Coercion -> Coercion -> Coercion
FunCo Role
r 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 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
ty1'
             k2 :: LintedType
k2 = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
when (Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Role
/= 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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable LintedType
ppr LintedType
ty1
                             , String -> SDoc
text String
"  To:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ty2])
     isUnBoxed :: PrimRep -> Bool
     isUnBoxed :: PrimRep -> Bool
isUnBoxed = Bool -> Bool
not (Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> Bool
isGcPtrRep

       -- see #9122 for discussion of these checks
     checkTypes :: LintedType -> LintedType -> LintM ()
checkTypes LintedType
t1 LintedType
t2
       = do { Bool -> SDoc -> LintM ()
checkWarnL (Bool -> Bool
not Bool
lev_poly1)
                         (String -> SDoc
report String
"left-hand type is levity-polymorphic")
            ; Bool -> SDoc -> LintM ()
checkWarnL (Bool -> Bool
not Bool
lev_poly2)
                         (String -> SDoc
report String
"right-hand type is levity-polymorphic")
            ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
when (Bool -> Bool
not (Bool
lev_poly1 Bool -> Bool -> Bool
|| Bool
lev_poly2)) (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 ()
Instance of class: Applicative of the constraint type Applicative LintM
zipWithM_ PrimRep -> PrimRep -> LintM ()
validateCoercion [PrimRep]
reps1 [PrimRep]
reps2 }}
       where
         lev_poly1 :: Bool
lev_poly1 = LintedType -> Bool
isTypeLevPoly LintedType
t1
         lev_poly2 :: Bool
lev_poly2 = LintedType -> Bool
isTypeLevPoly LintedType
t2

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

     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
Instance of class: Functor of the constraint type Functor LintM
<$> LintM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
Instance of class: HasDynFlags of the constraint type HasDynFlags LintM
getDynFlags
            ; Bool -> SDoc -> LintM ()
checkWarnL (PrimRep -> Bool
isUnBoxed PrimRep
rep1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq 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
External instance of the constraint type Eq JoinArity
== 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
External instance of the constraint type Monad Maybe
liftM2 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq 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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co Role
Phantom Role
r
            ; Coercion -> LintedType -> LintedType -> LintM ()
check_kinds Coercion
kco' LintedType
k1 LintedType
k2
            ; UnivCoProvenance -> LintM UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Coercion -> UnivCoProvenance
ProofIrrelProv Coercion
kco') }

     lint_prov LintedType
_ LintedType
_ prov :: UnivCoProvenance
prov@(PluginProv String
_) = UnivCoProvenance -> LintM UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
ppr Coercion
co)
                   JoinArity
2 ([SDoc] -> SDoc
vcat [Pair LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (Pair a)
External instance of the constraint type Outputable LintedType
ppr (Coercion -> Pair LintedType
coercionKind Coercion
co1'), Pair LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (Pair a)
External instance of the constraint type Outputable LintedType
ppr (Coercion -> Pair LintedType
coercionKind Coercion
co2')]))
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co (Coercion -> Role
coercionRole Coercion
co1) (Coercion -> Role
coercionRole Coercion
co2)
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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)
splitForAllTy_maybe LintedType
s, LintedType -> Maybe (Var, LintedType)
splitForAllTy_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
External instance of the constraint type Eq JoinArity
== 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 ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
the_co Role
Nominal Role
r0
                   ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Role -> JoinArity -> Coercion -> Coercion
NthCo Role
r0 JoinArity
n Coercion
co') }

         ; (Maybe (Var, LintedType), Maybe (Var, LintedType))
_ -> case (HasDebugCallStack => LintedType -> Maybe (TyCon, [LintedType])
LintedType -> Maybe (TyCon, [LintedType])
External instance of the constraint type HasDebugCallStack
splitTyConApp_maybe LintedType
s, HasDebugCallStack => LintedType -> Maybe (TyCon, [LintedType])
LintedType -> Maybe (TyCon, [LintedType])
External instance of the constraint type HasDebugCallStack
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
External instance of the constraint type Eq TyCon
== 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 ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
the_co Role
tr Role
r0
                   ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
ppr Coercion
the_co SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
s SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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 ()
External instance of the constraint type Outputable Coercion
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
ppr Coercion
the_co SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
s SDoc -> SDoc -> SDoc
$$ LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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 ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
arg Role
Nominal (Coercion -> Role
coercionRole Coercion
arg')

      ; case (LintedType -> Maybe (Var, LintedType)
splitForAllTy_ty_maybe LintedType
t1, LintedType -> Maybe (Var, LintedType)
splitForAllTy_ty_maybe LintedType
t2) of
         -- forall over tvar
         { (Just (Var
tv1,LintedType
_), Just (Var
tv2,LintedType
_))
             | HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
s1 LintedType -> LintedType -> Bool
`eqType` Var -> LintedType
tyVarKind Var
tv1
             , HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
s2 LintedType -> LintedType -> Bool
`eqType` Var -> LintedType
tyVarKind Var
tv2
             -> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
ppr Coercion
co)

         ; (Maybe (Var, LintedType), Maybe (Var, LintedType))
_ -> case (LintedType -> Maybe (Var, LintedType)
splitForAllTy_co_maybe LintedType
t1, LintedType -> Maybe (Var, LintedType)
splitForAllTy_co_maybe LintedType
t2) of
         -- forall over covar
         { (Just (Var
cv1, LintedType
_), Just (Var
cv2, LintedType
_))
             | HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
s1 LintedType -> LintedType -> Bool
`eqType` Var -> LintedType
varType Var
cv1
             , HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
s2 LintedType -> LintedType -> Bool
`eqType` Var -> LintedType
varType Var
cv2
             , CoercionTy Coercion
_ <- LintedType
s1
             , CoercionTy Coercion
_ <- LintedType
s2
             -> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
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 ()
Instance of class: Applicative of the constraint type Applicative LintM
unless (JoinArity
0 JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord JoinArity
<= JoinArity
ind Bool -> Bool -> Bool
&& JoinArity
ind JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord JoinArity
< 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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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)
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Traversable []
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
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Foldable []
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return ()
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Outputable Coercion
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' = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
s'
                 tk' :: LintedType
tk' = HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
t'
           ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
arg' Role
role (Coercion -> Role
coercionRole Coercion
arg')
           ; let ktv_kind_l :: LintedType
ktv_kind_l = HasCallStack => TCvSubst -> LintedType -> LintedType
TCvSubst -> LintedType -> LintedType
substTy TCvSubst
subst_l (Var -> LintedType
tyVarKind Var
ktv)
                 ktv_kind_r :: LintedType
ktv_kind_r = HasCallStack => 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 ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Coercion
ppr Coercion
co, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
sk', Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
ktv, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ktv_kind_l ] ))
           ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Instance of class: Applicative of the constraint type Applicative LintM
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
External instance of the constraint type Outputable Coercion
ppr Coercion
co, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
tk', Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
ktv, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ktv_kind_r ] ))
           ; (TCvSubst, TCvSubst) -> LintM (TCvSubst, TCvSubst)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 ()
External instance of the constraint type Outputable Coercion
lintRole Coercion
co' Role
Nominal (Coercion -> Role
coercionRole Coercion
co')
       ; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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)
Instance of class: Monad of the constraint type Monad LintM
External instance of the constraint type Traversable []
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
External instance of the constraint type Outputable Coercion
ppr Coercion
this ]
           Just Pair LintedType
_  -> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (CoAxiomRule -> [Coercion] -> Coercion
AxiomRuleCo CoAxiomRule
ax [Coercion]
cos') }
  where
  err :: 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
External instance of the constraint type Outputable FastString
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
External instance of the constraint type Eq Role
== Coercion -> Role
coercionRole Coercion
co = JoinArity -> [Role] -> [Coercion] -> LintM ()
lint_roles (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
External instance of the constraint type Num JoinArity
+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
External instance of the constraint type Num JoinArity
+JoinArity
1)
                      , String -> SDoc
text String
"Expected:" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Role
ppr Role
e
                      , String -> SDoc
text String
"Found:" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Role
ppr (Coercion -> Role
coercionRole Coercion
co) ]
  lint_roles JoinArity
_ [] []  = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type Num JoinArity
+ [Coercion] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
External instance of the constraint type Foldable []
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
External instance of the constraint type Num JoinArity
+ [Role] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
External instance of the constraint type Foldable []
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
External instance of the constraint type Outputable CoercionHole
ppr CoercionHole
h
       ; Coercion -> LintM Coercion
lintCoercion (Var -> Coercion
CoVarCo (CoercionHole -> Var
coHoleCoVar CoercionHole
h)) }


{-
************************************************************************
*                                                                      *
\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
       }

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_levity_poly :: Bool -- See Note [Checking for levity 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
/= :: StaticPtrCheck -> StaticPtrCheck -> Bool
$c/= :: StaticPtrCheck -> StaticPtrCheck -> Bool
== :: StaticPtrCheck -> StaticPtrCheck -> Bool
$c== :: StaticPtrCheck -> StaticPtrCheck -> Bool
Eq

defaultLintFlags :: LintFlags
defaultLintFlags :: LintFlags
defaultLintFlags = LF :: Bool -> Bool -> StaticPtrCheck -> Bool -> Bool -> LintFlags
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_report_unsat_syns :: Bool
lf_report_unsat_syns = Bool
True
                      , lf_check_levity_poly :: Bool
lf_check_levity_poly = Bool
True
                      }

newtype LintM a =
   LintM { LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM ::
            LintEnv ->
            WarnsAndErrs ->           -- Warning and error messages so far
            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
   deriving (a -> LintM b -> LintM a
(a -> b) -> LintM a -> LintM b
(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
<$ :: a -> LintM b -> LintM a
$c<$ :: forall a b. a -> LintM b -> LintM a
fmap :: (a -> b) -> LintM a -> LintM b
$cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
External instance of the constraint type Functor Maybe
Functor)

type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)

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

instance Applicative LintM where
      pure :: a -> LintM a
pure a
x = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
_ (Bag SDoc, Bag SDoc)
errs -> (a -> Maybe a
forall a. a -> Maybe a
Just a
x, (Bag SDoc, Bag SDoc)
errs)
      <*> :: 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
Instance of class: Monad of the constraint type Monad LintM
ap

instance Monad LintM where
  LintM a
m >>= :: LintM a -> (a -> LintM b) -> LintM b
>>= a -> LintM b
k  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe b, (Bag SDoc, Bag SDoc)))
-> LintM b
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM (\ LintEnv
env (Bag SDoc, Bag SDoc)
errs ->
                       let (Maybe a
res, (Bag SDoc, Bag SDoc)
errs') = LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM LintM a
m LintEnv
env (Bag SDoc, Bag SDoc)
errs in
                         case Maybe a
res of
                           Just a
r -> LintM b
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe b, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM (a -> LintM b
k a
r) LintEnv
env (Bag SDoc, Bag SDoc)
errs'
                           Maybe a
Nothing -> (Maybe b
forall a. Maybe a
Nothing, (Bag SDoc, Bag SDoc)
errs'))

instance MonadFail LintM where
    fail :: 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
 -> (Bag SDoc, Bag SDoc) -> (Maybe DynFlags, (Bag SDoc, Bag SDoc)))
-> LintM DynFlags
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM (\ LintEnv
e (Bag SDoc, Bag SDoc)
errs -> (DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just (LintEnv -> DynFlags
le_dynflags LintEnv
e), (Bag SDoc, Bag SDoc)
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

initL :: DynFlags -> LintFlags -> [Var]
       -> LintM a -> WarnsAndErrs    -- Warnings and errors
initL :: DynFlags -> LintFlags -> [Var] -> LintM a -> (Bag SDoc, Bag SDoc)
initL DynFlags
dflags LintFlags
flags [Var]
vars LintM a
m
  = case LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM LintM a
m LintEnv
env (Bag SDoc
forall a. Bag a
emptyBag, Bag SDoc
forall a. Bag a
emptyBag) of
      (Just a
_, (Bag SDoc, Bag SDoc)
errs) -> (Bag SDoc, Bag SDoc)
errs
      (Maybe a
Nothing, errs :: (Bag SDoc, Bag SDoc)
errs@(Bag SDoc
_, Bag SDoc
e)) | Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
e) -> (Bag SDoc, Bag SDoc)
errs
                             | Bool
otherwise -> String -> SDoc -> (Bag SDoc, Bag SDoc)
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 :: LintFlags
-> [LintLocInfo]
-> TCvSubst
-> VarEnv (Var, LintedType)
-> IdSet
-> DynFlags
-> LintEnv
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 }

setReportUnsat :: Bool -> LintM a -> LintM a
-- Switch off lf_report_unsat_syns
setReportUnsat :: Bool -> LintM a -> LintM a
setReportUnsat Bool
ru LintM a
thing_inside
  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc, Bag SDoc)
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
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM LintM a
thing_inside LintEnv
env' (Bag SDoc, Bag SDoc)
errs

-- See Note [Checking for levity polymorphism]
noLPChecks :: LintM a -> LintM a
noLPChecks :: LintM a -> LintM a
noLPChecks LintM a
thing_inside
  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \LintEnv
env (Bag SDoc, Bag SDoc)
errs ->
    let env' :: LintEnv
env' = LintEnv
env { le_flags :: LintFlags
le_flags = (LintEnv -> LintFlags
le_flags LintEnv
env) { lf_check_levity_poly :: Bool
lf_check_levity_poly = Bool
False } }
    in LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM LintM a
thing_inside LintEnv
env' (Bag SDoc, Bag SDoc)
errs

getLintFlags :: LintM LintFlags
getLintFlags :: LintM LintFlags
getLintFlags = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe LintFlags, (Bag SDoc, Bag SDoc)))
-> LintM LintFlags
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe LintFlags, (Bag SDoc, Bag SDoc)))
 -> LintM LintFlags)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe LintFlags, (Bag SDoc, Bag SDoc)))
-> LintM LintFlags
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc, Bag SDoc)
errs -> (LintFlags -> Maybe LintFlags
forall a. a -> Maybe a
Just (LintEnv -> LintFlags
le_flags LintEnv
env), (Bag SDoc, Bag SDoc)
errs)

checkL :: Bool -> MsgDoc -> LintM ()
checkL :: Bool -> SDoc -> LintM ()
checkL Bool
True  SDoc
_   = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 -> MsgDoc -> LintM ()
lintL :: Bool -> SDoc -> LintM ()
lintL = Bool -> SDoc -> LintM ()
checkL

checkWarnL :: Bool -> MsgDoc -> LintM ()
checkWarnL :: Bool -> SDoc -> LintM ()
checkWarnL Bool
True   SDoc
_  = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return ()
checkWarnL Bool
False SDoc
msg = SDoc -> LintM ()
addWarnL SDoc
msg

failWithL :: MsgDoc -> LintM a
failWithL :: SDoc -> LintM a
failWithL SDoc
msg = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> 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 :: MsgDoc -> LintM ()
addErrL :: SDoc -> LintM ()
addErrL SDoc
msg = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe (), (Bag SDoc, Bag SDoc)))
-> LintM ()
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe (), (Bag SDoc, Bag SDoc)))
 -> LintM ())
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe (), (Bag SDoc, Bag SDoc)))
-> 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 :: MsgDoc -> LintM ()
addWarnL :: SDoc -> LintM ()
addWarnL SDoc
msg = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe (), (Bag SDoc, Bag SDoc)))
-> LintM ()
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe (), (Bag SDoc, Bag SDoc)))
 -> LintM ())
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe (), (Bag SDoc, Bag SDoc)))
-> 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 MsgDoc -> MsgDoc -> Bag MsgDoc
addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg Bool
is_error LintEnv
env Bag SDoc
msgs SDoc
msg
  = ASSERT2( notNull loc_msgs, msg )
    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
External instance of the constraint type Outputable TCvSubst
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
   mk_msg :: SDoc -> SDoc
mk_msg SDoc
msg = Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevWarning SrcSpan
msg_span
                             (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
context)

addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
extra_loc LintM a
m
  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc, Bag SDoc)
errs ->
    LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
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 }) (Bag SDoc, Bag SDoc)
errs

inCasePat :: LintM Bool         -- A slight hack; see the unique call site
inCasePat :: LintM Bool
inCasePat = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe Bool, (Bag SDoc, Bag SDoc)))
-> LintM Bool
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe Bool, (Bag SDoc, Bag SDoc)))
 -> LintM Bool)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe Bool, (Bag SDoc, Bag SDoc)))
-> LintM Bool
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc, Bag SDoc)
errs -> (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (LintEnv -> Bool
is_case_pat LintEnv
env), (Bag SDoc, Bag SDoc)
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 :: Var -> LintedType -> LintM a -> LintM a
addInScopeId Var
id LintedType
linted_ty LintM a
m
  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> 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 }) (Bag SDoc, Bag SDoc)
errs ->
    LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
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 }) (Bag SDoc, Bag SDoc)
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
 -> (Bag SDoc, Bag SDoc)
 -> (Maybe (VarEnv (Var, LintedType)), (Bag SDoc, Bag SDoc)))
-> LintM (VarEnv (Var, LintedType))
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM (\LintEnv
env (Bag SDoc, Bag SDoc)
errs -> (VarEnv (Var, LintedType) -> Maybe (VarEnv (Var, LintedType))
forall a. a -> Maybe a
Just (LintEnv -> VarEnv (Var, LintedType)
le_ids LintEnv
env), (Bag SDoc, Bag SDoc)
errs))

extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a
extendTvSubstL :: Var -> LintedType -> LintM a -> LintM a
extendTvSubstL Var
tv LintedType
ty LintM a
m
  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc, Bag SDoc)
errs ->
    LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
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 }) (Bag SDoc, Bag SDoc)
errs

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

markAllJoinsBad :: LintM a -> LintM a
markAllJoinsBad :: LintM a -> LintM a
markAllJoinsBad LintM a
m
  = (LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM ((LintEnv
  -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
 -> LintM a)
-> (LintEnv
    -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc, Bag SDoc)
errs -> LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
forall a.
LintM a
-> LintEnv
-> (Bag SDoc, Bag SDoc)
-> (Maybe a, (Bag SDoc, Bag SDoc))
unLintM LintM a
m (LintEnv
env { le_joins :: IdSet
le_joins = IdSet
emptyVarSet }) (Bag SDoc, Bag SDoc)
errs

markAllJoinsBadIf :: Bool -> LintM a -> LintM a
markAllJoinsBadIf :: 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
 -> (Bag SDoc, Bag SDoc) -> (Maybe IdSet, (Bag SDoc, Bag SDoc)))
-> LintM IdSet
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM (\ LintEnv
env (Bag SDoc, Bag SDoc)
errs -> (IdSet -> Maybe IdSet
forall a. a -> Maybe a
Just (LintEnv -> IdSet
le_joins LintEnv
env), (Bag SDoc, Bag SDoc)
errs))

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

getInScope :: LintM InScopeSet
getInScope :: LintM InScopeSet
getInScope = (LintEnv
 -> (Bag SDoc, Bag SDoc)
 -> (Maybe InScopeSet, (Bag SDoc, Bag SDoc)))
-> LintM InScopeSet
forall a.
(LintEnv
 -> (Bag SDoc, Bag SDoc) -> (Maybe a, (Bag SDoc, Bag SDoc)))
-> LintM a
LintM (\ LintEnv
env (Bag SDoc, Bag SDoc)
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), (Bag SDoc, Bag SDoc)
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
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
External instance of the constraint type OutputableBndr Var
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
External instance of the constraint type OutputableBndr Var
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
External instance of the constraint type NamedThing Var
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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return (Var -> Maybe JoinArity
isJoinId_maybe Var
id')
            Maybe Var
Nothing  -> Maybe JoinArity -> LintM (Maybe JoinArity)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad LintM
return Maybe JoinArity
forall a. Maybe a
Nothing }

ensureEqTys :: LintedType -> LintedType -> MsgDoc -> 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

lintRole :: Outputable thing
          => thing     -- where the role appeared
          -> Role      -- expected
          -> Role      -- actual
          -> LintM ()
lintRole :: 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
External instance of the constraint type Eq Role
== Role
r2)
          (String -> SDoc
text String
"Role incompatibility: expected" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Role
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
External instance of the constraint type Outputable Role
ppr Role
r2 SDoc -> SDoc -> SDoc
$$
           String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> thing -> SDoc
forall a. Outputable a => a -> SDoc
Evidence bound by a type signature of the constraint type Outputable thing
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
External instance of the constraint type NamedThing Var
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
External instance of the constraint type NamedThing Var
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
External instance of the constraint type NamedThing Var
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
External instance of the constraint type NamedThing Var
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
External instance of the constraint type NamedThing Var
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
External instance of the constraint type NamedThing Var
getSrcLoc ([Var] -> Var
forall a. [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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
e)

dumpLoc (CaseAlt (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
External instance of the constraint type Outputable AltCon
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pp_binders [Var]
args))

dumpLoc (CasePat (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
External instance of the constraint type Outputable AltCon
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
scrut))

dumpLoc (IdTy Var
b)
  = (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
External instance of the constraint type NamedThing Var
getSrcLoc Var
b, String -> SDoc
text String
"In the type of a binder:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
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
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable Coercion
ppr Coercion
co))

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
External instance of the constraint type Outputable Var
ppr Var
b, SDoc
dcolon, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (Var -> LintedType
idType Var
b)]
            | Bool
otherwise = [SDoc] -> SDoc
hsep [Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
b, SDoc
dcolon, LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (Var -> LintedType
tyVarKind Var
b)]

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

mkDefaultArgsMsg :: [Var] -> MsgDoc
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
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Var
ppr [Var]
args)

mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
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
External instance of the constraint type Outputable LintedType
ppr LintedType
ty1,
                   String -> SDoc
text String
"Annotation on case:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ty2,
                   String -> SDoc
text String
"Alt Rhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
e ])

mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
var,
          String -> SDoc
text String
"Result binder type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
var_ty,--(idType var),
          String -> SDoc
text String
"Scrutinee type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
scrut_ty,
     [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Current TCv subst", TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable TCvSubst
ppr TCvSubst
subst]]

mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
e)

nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
e)

mkBadConMsg :: TyCon -> DataCon -> MsgDoc
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
External instance of the constraint type Outputable TyCon
ppr TyCon
tycon,
        String -> SDoc
text String
"Data con:" SDoc -> SDoc -> SDoc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable DataCon
ppr DataCon
datacon
    ]

mkBadPatMsg :: Type -> Type -> MsgDoc
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
External instance of the constraint type Outputable LintedType
ppr LintedType
con_result_ty,
        String -> SDoc
text String
"Scrutinee type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
scrut_ty
    ]

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

mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
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
External instance of the constraint type Outputable LintedType
ppr LintedType
scrut_ty,
           String -> SDoc
text String
"Alternative:" SDoc -> SDoc -> SDoc
<+> Alt Var -> SDoc
forall a. OutputableBndr a => (AltCon, [a], Expr a) -> SDoc
External instance of the constraint type OutputableBndr Var
pprCoreAlt Alt Var
alt ]

mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
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
External instance of the constraint type Outputable LintedType
ppr LintedType
scrut_ty,
           String -> SDoc
text String
"Alternative:" SDoc -> SDoc -> SDoc
<+> Alt Var -> SDoc
forall a. OutputableBndr a => (AltCon, [a], Expr a) -> SDoc
External instance of the constraint type OutputableBndr Var
pprCoreAlt Alt Var
alt ]


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

mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
mkAppMsg :: LintedType -> LintedType -> CoreExpr -> SDoc
mkAppMsg LintedType
fun_ty LintedType
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
"Fun type:") JoinArity
4 (LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_ty),
              SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg:") JoinArity
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
arg)]

mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
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
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_ty),
              SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg:") JoinArity
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
arg)]

mkLetErr :: TyVar -> CoreExpr -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
bndr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
rhs)]

mkTyAppMsg :: Type -> Type -> MsgDoc
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
External instance of the constraint type Outputable LintedType
ppr LintedType
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
ty)),
              SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg type:")
                 JoinArity
4 (LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
arg_ty))]

emptyRec :: CoreExpr -> MsgDoc
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
e)

mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
binder],
     [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Binder's type:", LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (Var -> LintedType
idType Var
binder)],
     [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Rhs type:", LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ty]]

mkLetAppMsg :: CoreExpr -> MsgDoc
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
e)

badBndrTyMsg :: Id -> SDoc -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
binder
         , String -> SDoc
text String
"Binder's type:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (Var -> LintedType
idType Var
binder) ]

mkStrictMsg :: Id -> MsgDoc
mkStrictMsg :: Var -> SDoc
mkStrictMsg Var
binder
  = [SDoc] -> SDoc
vcat [[SDoc] -> SDoc
hsep [String -> SDoc
text String
"Recursive or top-level binder has strict demand info:",
                     Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
binder],
              [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Binder's demand info:", Demand -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall s u.
(Outputable s, Outputable u) =>
Outputable (JointDmd s u)
External instance of the constraint type Outputable (Str StrDmd)
External instance of the constraint type Outputable (Use UseDmd)
ppr (Var -> Demand
idDemandInfo Var
binder)]
             ]

mkNonTopExportedMsg :: Id -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
binder]

mkNonTopExternalNameMsg :: Id -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
binder]

mkTopNonLitStrMsg :: Id -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
binder]

mkKindErrMsg :: TyVar -> Type -> MsgDoc
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
External instance of the constraint type Outputable Var
ppr Var
tyvar SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable LintedType
ppr LintedType
arg_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr (HasDebugCallStack => LintedType -> LintedType
LintedType -> LintedType
External instance of the constraint type HasDebugCallStack
typeKind LintedType
arg_ty))]

mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
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
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
ppr CoreExpr
expr)

mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc
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
External instance of the constraint type Outputable LintedType
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 -> MsgDoc
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
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable LintedType
ppr LintedType
ty
               , String -> SDoc
text String
"co:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Coercion
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
External instance of the constraint type Outputable Var
ppr Var
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable Var
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
External instance of the constraint type Outputable Var
ppr Var
var SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
ty)

mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
mkBadJoinArityMsg :: Var -> JoinArity -> JoinArity -> CoreExpr -> SDoc
mkBadJoinArityMsg Var
var JoinArity
ar JoinArity
nlams 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
External instance of the constraint type Outputable Var
ppr Var
var,
           String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
ppr JoinArity
ar,
           String -> SDoc
text String
"Number of lambdas:" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
ppr JoinArity
nlams,
           String -> SDoc
text String
"Rhs = " SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Var
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
External instance of the constraint type Outputable Var
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
External instance of the constraint type Outputable Var
ppr Var
var,
           String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
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
External instance of the constraint type Outputable Var
ppr Var
bndr SDoc -> SDoc -> SDoc
<> IdDetails -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable IdDetails
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
External instance of the constraint type Outputable Var
ppr Var
bndr
         , String -> SDoc
text String
"Arity at binding site:" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
ppr JoinArity
join_arity_bndr
         , String -> SDoc
text String
"Arity at occurrence:  " SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
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
External instance of the constraint type Outputable Var
ppr Var
bndr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
bndr_ty
         , String -> SDoc
text String
"Occurrence:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr Var
var SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
ppr LintedType
var_ty
         , String -> SDoc
text String
"  Before subst:" SDoc -> SDoc -> SDoc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable LintedType
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
External instance of the constraint type Outputable Var
ppr Var
bndr
         , String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
ppr JoinArity
join_arity
         , String -> SDoc
text String
"Rule:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable CoreRule
ppr CoreRule
rule ]

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

dupVars :: [NonEmpty Var] -> MsgDoc
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
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Var
ppr ((NonEmpty Var -> [Var]) -> [NonEmpty Var] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Var -> [Var]
forall (t :: * -> *) a. Foldable t => t a -> [a]
External instance of the constraint type Foldable NonEmpty
toList [NonEmpty Var]
vars))

dupExtVars :: [NonEmpty Name] -> MsgDoc
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
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Name
ppr ((NonEmpty Name -> [Name]) -> [NonEmpty Name] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
External instance of the constraint type Foldable NonEmpty
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 = do
  -- Run the pass as we normally would
  DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type HasDynFlags CoreM
getDynFlags
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type Applicative CoreM
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoAnnotationLinting DynFlags
dflags) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
    IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type MonadIO CoreM
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO ()
Err.showPass DynFlags
dflags 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 ()
External instance of the constraint type Applicative CoreM
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 (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type MonadIO CoreM
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO ()
Err.showPass DynFlags
dflags 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 (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type MonadIO CoreM
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO ()
Err.showPass DynFlags
dflags 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 ()
External instance of the constraint type Applicative CoreM
when (Bool -> Bool
not ([SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
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 (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad CoreM
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
External instance of the constraint type HasDynFlags CoreM
getDynFlags
  let removeFlag :: HscEnv -> HscEnv
removeFlag HscEnv
env = HscEnv
env{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags{ debugLevel :: JoinArity
debugLevel = JoinArity
0} }
      withoutFlag :: CoreM a -> CoreM (a, SimplCount)
withoutFlag CoreM a
corem =
          -- TODO: supply tag here as well ?
        IO (a, SimplCount) -> CoreM (a, SimplCount)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type MonadIO CoreM
liftIO (IO (a, SimplCount) -> CoreM (a, SimplCount))
-> CoreM (IO (a, SimplCount)) -> CoreM (a, SimplCount)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
External instance of the constraint type Monad CoreM
=<< HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM (HscEnv
 -> RuleBase
 -> Char
 -> Module
 -> ModuleSet
 -> PrintUnqualified
 -> SrcSpan
 -> CoreM a
 -> IO (a, SimplCount))
-> CoreM HscEnv
-> CoreM
     (RuleBase
      -> Char
      -> Module
      -> ModuleSet
      -> PrintUnqualified
      -> SrcSpan
      -> CoreM a
      -> IO (a, SimplCount))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor CoreM
<$> (HscEnv -> HscEnv) -> CoreM HscEnv -> CoreM HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor CoreM
fmap HscEnv -> HscEnv
removeFlag CoreM HscEnv
getHscEnv CoreM
  (RuleBase
   -> Char
   -> Module
   -> ModuleSet
   -> PrintUnqualified
   -> SrcSpan
   -> CoreM a
   -> IO (a, SimplCount))
-> CoreM RuleBase
-> CoreM
     (Char
      -> Module
      -> ModuleSet
      -> PrintUnqualified
      -> SrcSpan
      -> CoreM a
      -> IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*> CoreM RuleBase
getRuleBase CoreM
  (Char
   -> Module
   -> ModuleSet
   -> PrintUnqualified
   -> SrcSpan
   -> CoreM a
   -> IO (a, SimplCount))
-> CoreM Char
-> CoreM
     (Module
      -> ModuleSet
      -> PrintUnqualified
      -> SrcSpan
      -> CoreM a
      -> IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*>
                                CoreM Char
getUniqMask CoreM
  (Module
   -> ModuleSet
   -> PrintUnqualified
   -> SrcSpan
   -> CoreM a
   -> IO (a, SimplCount))
-> CoreM Module
-> CoreM
     (ModuleSet
      -> PrintUnqualified -> SrcSpan -> CoreM a -> IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*> CoreM Module
forall (m :: * -> *). HasModule m => m Module
External instance of the constraint type HasModule CoreM
getModule CoreM
  (ModuleSet
   -> PrintUnqualified -> SrcSpan -> CoreM a -> IO (a, SimplCount))
-> CoreM ModuleSet
-> CoreM
     (PrintUnqualified -> SrcSpan -> CoreM a -> IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*>
                                CoreM ModuleSet
getVisibleOrphanMods CoreM
  (PrintUnqualified -> SrcSpan -> CoreM a -> IO (a, SimplCount))
-> CoreM PrintUnqualified
-> CoreM (SrcSpan -> CoreM a -> IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*>
                                CoreM PrintUnqualified
getPrintUnqualified CoreM (SrcSpan -> CoreM a -> IO (a, SimplCount))
-> CoreM SrcSpan -> CoreM (CoreM a -> IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*> CoreM SrcSpan
getSrcSpanM CoreM (CoreM a -> IO (a, SimplCount))
-> CoreM (CoreM a) -> CoreM (IO (a, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative CoreM
<*>
                                CoreM a -> CoreM (CoreM a)
forall (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type Applicative CoreM
pure CoreM a
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 = (Tickish Var -> Bool) -> Expr b -> Expr b
forall b. (Tickish Var -> Bool) -> Expr b -> Expr b
stripTicksE (Bool -> Bool
not (Bool -> Bool) -> (Tickish Var -> Bool) -> Tickish Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Var -> Bool
forall id. Tickish id -> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor CoreM
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)
forall {a}. CoreM a -> CoreM (a, 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)