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

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


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

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

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

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

import GHC.Prelude

import GHC.Driver.Session

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

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

import GHC.Core.Opt.Monad

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

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

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

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

import Control.Monad
import Data.Foldable      ( for_, toList )
import Data.List.NonEmpty ( NonEmpty(..), groupWith )
import Data.List          ( partition )
import Data.Maybe
import GHC.Data.Pair
import GHC.Base (oneShot)
import GHC.Data.Unboxed

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

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

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

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

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

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

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

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

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

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

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

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

 We check this invariant in lintType.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

However ghc will compile this to:

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

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

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

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


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

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

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

  , EndPassConfig -> NamePprCtx
ep_namePprCtx :: !NamePprCtx

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

  , EndPassConfig -> SDoc
ep_prettyPass :: !SDoc

  , EndPassConfig -> SDoc
ep_passDetails :: !SDoc
  }

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

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

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

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

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

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

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

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

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

  | Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
warns)
  , LogFlags -> Bool
log_enable_debug (Logger -> LogFlags
logFlags Logger
logger)
  , Bool
display_warnings
  -- If the Core linter encounters an error, output to stderr instead of
  -- stdout (#13342)
  = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
Err.MCInfo SrcSpan
noSrcSpan
      (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
        (String -> SDoc -> SDoc
lint_banner String
"warnings" SDoc
pp_what SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Bag SDoc -> SDoc
Err.pprMessageBag ((SDoc -> SDoc) -> Bag SDoc -> Bag SDoc
forall a b. (a -> b) -> Bag a -> Bag b
mapBag (SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine) Bag SDoc
warns))

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

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

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

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

    -- dups_ext checks for names with different uniques
    -- but the same External name M.n.  We don't
    -- allow this at top level:
    --    M.n{r3}  = ...
    --    M.n{r29} = ...
    -- because they both get the same linker symbol
    ext_dups :: [NonEmpty Name]
ext_dups = ([Name], [NonEmpty Name]) -> [NonEmpty Name]
forall a b. (a, b) -> b
snd ((Name -> Name -> Ordering) -> [Name] -> ([Name], [NonEmpty Name])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Name -> Name -> Ordering
ord_ext ((Var -> Name) -> [Var] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Name
Var.varName [Var]
binders))
    ord_ext :: Name -> Name -> Ordering
ord_ext Name
n1 Name
n2 | Just Module
m1 <- Name -> Maybe Module
nameModule_maybe Name
n1
                  , Just Module
m2 <- Name -> Maybe Module
nameModule_maybe Name
n2
                  = (Module, OccName) -> (Module, OccName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Module
m1, Name -> OccName
nameOccName Name
n1) (Module
m2, Name -> OccName
nameOccName Name
n2)
                  | Bool
otherwise = Ordering
LT

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

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

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

-}

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

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

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

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

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

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

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

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

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

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

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

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

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

       ; LintFlags
flags <- LintM LintFlags
getLintFlags

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

       ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_check_inline_loop_breakers LintFlags
flags
               Bool -> Bool -> Bool
&& Unfolding -> Bool
isStableUnfolding (Var -> Unfolding
realIdUnfolding Var
binder)
               Bool -> Bool -> Bool
&& OccInfo -> Bool
isStrongLoopBreaker (Var -> OccInfo
idOccInfo Var
binder)
               Bool -> Bool -> Bool
&& InlinePragma -> Bool
isInlinePragma (Var -> InlinePragma
idInlinePragma Var
binder))
              (SDoc -> LintM ()
addWarnL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"INLINE binder is (non-rule) loop breaker:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder))
              -- Only non-rule loop breakers inhibit inlining

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

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

       ; Bool -> SDoc -> LintM ()
checkL (LintedType -> JoinArity
typeArity (Var -> LintedType
idType Var
binder) JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
>= Var -> JoinArity
idArity Var
binder)
           (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"idArity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> JoinArity
idArity Var
binder) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exceeds typeArity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LintedType -> JoinArity
typeArity (Var -> LintedType
idType Var
binder)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder)

       -- See Note [idArity varies independently of dmdTypeDepth]
       --     in GHC.Core.Opt.DmdAnal
       ; case DmdSig -> ([Demand], Divergence)
splitDmdSig (Var -> DmdSig
idDmdSig Var
binder) of
           ([Demand]
demands, Divergence
result_info) | Divergence -> Bool
isDeadEndDiv Divergence
result_info ->
             Bool -> SDoc -> LintM ()
checkL ([Demand]
demands [Demand] -> JoinArity -> Bool
forall a. [a] -> JoinArity -> Bool
`lengthAtLeast` Var -> JoinArity
idArity Var
binder)
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"idArity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> JoinArity
idArity Var
binder) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
               String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exceeds arity imposed by the strictness signature" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
               DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> DmdSig
idDmdSig Var
binder) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
               Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder)

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

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

       ; LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
UnfoldingOf Var
binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
         Var -> LintedType -> Unfolding -> LintM ()
lintIdUnfolding Var
binder LintedType
binder_ty (Var -> Unfolding
idUnfolding Var
binder)
       ; () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return () }

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

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

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

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

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

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

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

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

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

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

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

Notice that

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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



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

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

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

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

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

lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv)
lintCoreExpr (Var Var
var)
  = do
      var_pair :: (LintedType, UsageEnv)
var_pair@(LintedType
var_ty, UsageEnv
_) <- Var -> JoinArity -> LintM (LintedType, UsageEnv)
lintIdOcc Var
var JoinArity
0
      CoreExpr -> [CoreExpr] -> LintedType -> LintM ()
checkCanEtaExpand (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
var) [] LintedType
var_ty
      (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LintedType, UsageEnv)
var_pair

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lintCoreExpr (Coercion Coercion
co)
  = do { Coercion
co' <- LintLocInfo -> LintM Coercion -> LintM Coercion
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Coercion -> LintLocInfo
InCo Coercion
co) (LintM Coercion -> LintM Coercion)
-> LintM Coercion -> LintM Coercion
forall a b. (a -> b) -> a -> b
$
                Coercion -> LintM Coercion
lintCoercion Coercion
co
       ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> LintedType
coercionType Coercion
co', UsageEnv
zeroUE) }

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

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

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

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

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

        ; (LintedType, UsageEnv) -> LintM (LintedType, UsageEnv)
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LintedType
linted_bndr_ty, UsageEnv
usage) }

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

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

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

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

checkJoinOcc :: Id -> JoinArity -> LintM ()
-- Check that if the occurrence is a JoinId, then so is the
-- binding site, and it's a valid join Id
checkJoinOcc :: Var -> JoinArity -> LintM ()
checkJoinOcc Var
var JoinArity
n_args
  | 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
forall doc. IsLine doc => String -> doc
text String
"join set " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IdSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdSet
join_set SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                                    Var -> SDoc
invalidJoinOcc Var
var) } ;

           Just JoinArity
join_arity_bndr ->

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

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

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

-- | This function checks that we are able to perform eta expansion for
-- functions with no binding, in order to satisfy invariant I3
-- from Note [Representation polymorphism invariants] in GHC.Core.
checkCanEtaExpand :: CoreExpr   -- ^ the function (head of the application) we are checking
                  -> [CoreArg]  -- ^ the arguments to the application
                  -> LintedType -- ^ the instantiated type of the overall application
                  -> LintM ()
checkCanEtaExpand :: CoreExpr -> [CoreExpr] -> LintedType -> LintM ()
checkCanEtaExpand (Var Var
fun_id) [CoreExpr]
args LintedType
app_ty
  = do { Bool
do_rep_poly_checks <- LintFlags -> Bool
lf_check_fixed_rep (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
       ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
do_rep_poly_checks Bool -> Bool -> Bool
&& Var -> Bool
hasNoBinding Var
fun_id) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
           Bool -> SDoc -> LintM ()
checkL ([LintedType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LintedType]
bad_arg_tys) SDoc
err_msg }
    where
      arity :: Arity
      arity :: JoinArity
arity = Var -> JoinArity
idArity Var
fun_id

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

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

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

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

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

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

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

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

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

and consider the expression

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

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

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

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

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

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

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

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

For example, suppose we have (comment 8)

  data T a where
    TInt :: T Int

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

  data Foo = Foo !(T Bool)

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

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

  absurdFoo (Foo x) = case x of

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

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


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

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

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

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

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

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

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

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

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

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

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

       ; CoreExpr
-> LintedType
-> LintedType
-> UsageEnv
-> UsageEnv
-> LintM (LintedType, UsageEnv)
lintValApp CoreExpr
arg LintedType
fun_ty LintedType
arg_ty UsageEnv
fun_ue UsageEnv
arg_ue }

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

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



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

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

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

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

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

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

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

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

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

     ; LintedType
alt_ty <- LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (CoreExpr -> LintLocInfo
CaseTy CoreExpr
scrut) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
                 LintedType -> LintM LintedType
lintValueType LintedType
alt_ty
     ; LintedType
var_ty <- LintLocInfo -> LintM LintedType -> LintM LintedType
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
IdTy Var
var) (LintM LintedType -> LintM LintedType)
-> LintM LintedType -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
                 LintedType -> LintM LintedType
lintValueType (Var -> LintedType
idType Var
var)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lintCoreAlt Var
case_bndr LintedType
scrut_ty LintedType
_scrut_mult LintedType
alt_ty alt :: Alt Var
alt@(Alt (DataAlt DataCon
con) [Var]
args CoreExpr
rhs)
  | TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
con)
  = UsageEnv
zeroUE UsageEnv -> LintM () -> LintM UsageEnv
forall a b. a -> LintM b -> LintM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SDoc -> LintM ()
addErrL (LintedType -> Alt Var -> SDoc
mkNewTyDataConAltMsg LintedType
scrut_ty Alt Var
alt)
  | Just (TyCon
tycon, [LintedType]
tycon_arg_tys) <- (() :: Constraint) => LintedType -> Maybe (TyCon, [LintedType])
LintedType -> Maybe (TyCon, [LintedType])
splitTyConApp_maybe LintedType
scrut_ty
  = LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Alt Var -> LintLocInfo
CaseAlt Alt Var
alt) (LintM UsageEnv -> LintM UsageEnv)
-> LintM UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$  do
    {   -- First instantiate the universally quantified
        -- type variables of the data constructor
        -- We've already check
      Bool -> SDoc -> LintM ()
lintL (TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
con) (TyCon -> DataCon -> SDoc
mkBadConMsg TyCon
tycon DataCon
con)
    ; let { con_payload_ty :: LintedType
con_payload_ty = (() :: Constraint) => LintedType -> [LintedType] -> LintedType
LintedType -> [LintedType] -> LintedType
piResultTys (DataCon -> LintedType
dataConRepType DataCon
con) [LintedType]
tycon_arg_tys
          ; binderMult :: PiTyBinder -> LintedType
binderMult (Named ForAllTyBinder
_)   = LintedType
ManyTy
          ; binderMult (Anon Scaled LintedType
st FunTyFlag
_) = Scaled LintedType -> LintedType
forall a. Scaled a -> LintedType
scaledMult Scaled LintedType
st
          -- See Note [Validating multiplicities in a case]
          ; multiplicities :: [LintedType]
multiplicities = (PiTyBinder -> LintedType) -> [PiTyBinder] -> [LintedType]
forall a b. (a -> b) -> [a] -> [b]
map PiTyBinder -> LintedType
binderMult ([PiTyBinder] -> [LintedType]) -> [PiTyBinder] -> [LintedType]
forall a b. (a -> b) -> a -> b
$ ([PiTyBinder], LintedType) -> [PiTyBinder]
forall a b. (a, b) -> a
fst (([PiTyBinder], LintedType) -> [PiTyBinder])
-> ([PiTyBinder], LintedType) -> [PiTyBinder]
forall a b. (a -> b) -> a -> b
$ LintedType -> ([PiTyBinder], LintedType)
splitPiTys LintedType
con_payload_ty }

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

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

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

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

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

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

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

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

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

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

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

       ; Subst -> LintM a -> LintM a
forall a. Subst -> LintM a -> LintM a
updateSubst Subst
subst' (Var -> LintM a
thing_inside Var
tcv') }

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

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

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

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

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

       -- Check that a join-id is a not-top-level let-binding
       ; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Var -> Bool
isJoinId Var
id) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
         Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not Bool
is_top_lvl Bool -> Bool -> Bool
&& Bool
is_let_bind) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
         Var -> SDoc
mkBadJoinBindMsg Var
id

       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);
       -- if so, it should be a CoVar, and checked by lintCoVarBndr
       ; Bool -> SDoc -> LintM ()
lintL (Bool -> Bool
not (LintedType -> Bool
isCoVarType LintedType
id_ty))
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Non-CoVar has coercion type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LintedType
id_ty)

       -- Check that the lambda binder has no value or OtherCon unfolding.
       -- See #21496
       ; Bool -> SDoc -> LintM ()
lintL (Bool -> Bool
not (BindingSite
bind_site BindingSite -> BindingSite -> Bool
forall a. Eq a => a -> a -> Bool
== BindingSite
LambdaBind Bool -> Bool -> Bool
&& Unfolding -> Bool
isEvaldUnfolding (Var -> Unfolding
idUnfolding Var
id)))
                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Lambda binder with value or OtherCon unfolding.")

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

       ; Var -> LintedType -> LintM a -> LintM a
forall a. Var -> LintedType -> LintM a -> LintM a
addInScopeId Var
id LintedType
linted_ty (LintM a -> LintM a) -> LintM a -> LintM a
forall a b. (a -> b) -> a -> b
$
         Var -> LintM a
thing_inside (Var -> LintedType -> Var
setIdType Var
id LintedType
linted_ty) }
  where
    id_ty :: LintedType
id_ty = Var -> LintedType
idType Var
id

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

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

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

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

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

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

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

           -- In GHCi we may lint an expression with a free
           -- type variable.  Then it won't be in the
           -- substitution, but it should be in scope
           Maybe LintedType
Nothing | Var
tv Var -> Subst -> Bool
`isInScope` Subst
subst
                   -> LintedType -> LintM LintedType
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> LintedType
TyVarTy Var
tv)
                   | Bool
otherwise
                   -> SDoc -> LintM LintedType
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM LintedType) -> SDoc -> LintM LintedType
forall a b. (a -> b) -> a -> b
$
                      SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The type variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
tv)
                         JoinArity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"TyConApp to the left of AppTy:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LintedType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LintedType
ty
  | Bool
otherwise
  = do { LintedType
t1' <- LintedType -> LintM LintedType
lintType LintedType
t1
       ; LintedType
t2' <- LintedType -> LintM LintedType
lintType LintedType
t2
       ; LintedType -> LintedType -> [LintedType] -> LintM ()
lint_ty_app LintedType
ty ((() :: Constraint) => LintedType -> LintedType
LintedType -> LintedType
typeKind LintedType
t1') [LintedType
t2']
       ; LintedType -> LintM LintedType
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LintedType -> LintedType -> LintedType
AppTy LintedType
t1' LintedType
t2') }

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

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

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

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

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

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

       ; LintedType -> LintM LintedType
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForAllTyBinder -> LintedType -> LintedType
ForAllTy (Var -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Var
tcv' ForAllTyFlag
vis) LintedType
body_ty') }

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

lintType (CastTy LintedType
ty Coercion
co)
  = do { LintedType
ty' <- LintedType -> LintM LintedType
lintType LintedType
ty
       ; Coercion
co' <- Coercion -> LintM Coercion
lintStarCoercion Coercion
co
       ; let tyk :: LintedType
tyk = (() :: Constraint) => LintedType -> LintedType
LintedType -> LintedType
typeKind LintedType
ty'
             cok :: LintedType
cok = Coercion -> LintedType
coercionLKind Coercion
co'
       ; LintedType -> LintedType -> SDoc -> LintM ()
ensureEqTys LintedType
tyk LintedType
cok (LintedType -> Coercion -> LintedType -> LintedType -> SDoc
mkCastTyErr LintedType
ty Coercion
co LintedType
tyk LintedType
cok)
       ; LintedType -> LintM LintedType
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LintedType -> Coercion -> LintedType
CastTy LintedType
ty' Coercion
co') }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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


-- lints a coercion, confirming that its lh kind and its rh kind are both *
-- also ensures that the role is Nominal
lintStarCoercion :: InCoercion -> LintM LintedCoercion
lintStarCoercion :: Coercion -> LintM Coercion
lintStarCoercion Coercion
g
  = do { 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
forall doc. IsLine doc => String -> doc
text String
"the kind of the left type in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
g)
       ; LintedType -> SDoc -> LintM ()
checkValueType LintedType
t2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the kind of the right type in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
g)
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
g Role
Nominal (Coercion -> Role
coercionRole Coercion
g)
       ; Coercion -> LintM Coercion
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
g' }

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

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

  | Bool
otherwise
  = do { Subst
subst <- LintM Subst
getSubst
       ; case Subst -> Var -> Maybe Coercion
lookupCoVar Subst
subst Var
cv of
           Just Coercion
linted_co -> Coercion -> LintM Coercion
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
linted_co ;
           Maybe Coercion
Nothing
              | Var
cv Var -> Subst -> Bool
`isInScope` Subst
subst
                   -> Coercion -> LintM Coercion
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Coercion
CoVarCo Var
cv)
              | Bool
otherwise
                   ->
                      -- lintCoBndr always extends the substitution
                      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
forall doc. IsLine doc => String -> doc
text String
"The coercion variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
cv)
                         JoinArity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is out of scope")
     }


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

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

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

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

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

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

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

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

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