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

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


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

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

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

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

import GHC.Prelude

import GHC.Driver.DynFlags

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

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

import GHC.Core.Opt.Monad

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

import GHC.Builtin.Names
import GHC.Builtin.Types.Prim

import GHC.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 GHC.Data.Pair
import GHC.Base (oneShot)
import GHC.Data.Unboxed

import Control.Monad
import Data.Foldable      ( for_, toList )
import Data.List.NonEmpty ( NonEmpty(..), groupWith )
import Data.Maybe
import Data.IntMap.Strict ( IntMap )
import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )

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

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

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

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

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

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

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

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

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

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

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

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

 We check this invariant in lintType.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

However ghc will compile this to:

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

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

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

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

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

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

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

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

  , EndPassConfig -> NamePprCtx
ep_namePprCtx :: !NamePprCtx

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

  , EndPassConfig -> SDoc
ep_prettyPass :: !SDoc

  , EndPassConfig -> SDoc
ep_passDetails :: !SDoc
  }

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

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

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

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

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

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

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

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

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

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

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

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

-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
--   Returns (warnings, errors)
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
lintCoreBindings' LintConfig
cfg CoreProgram
binds
  = LintConfig -> LintM ((), [UsageEnv]) -> WarnsAndErrs
forall a. LintConfig -> LintM a -> WarnsAndErrs
initL LintConfig
cfg (LintM ((), [UsageEnv]) -> WarnsAndErrs)
-> LintM ((), [UsageEnv]) -> WarnsAndErrs
forall a b. (a -> b) -> a -> b
$
    LintLocInfo -> LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv])
forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
TopLevelBindings           (LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv]))
-> LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv])
forall a b. (a -> b) -> a -> b
$
    do { -- Check that all top-level binders are distinct
         -- We do not allow  [NonRec x=1, NonRec y=x, NonRec x=2]
         -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal
         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 for External top level binders with the same M.n name
       ; 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)

         -- Typecheck the bindings
       ; TopLevelFlag
-> [(Var, CoreExpr)]
-> ([Var] -> LintM ())
-> LintM ((), [UsageEnv])
forall a.
TopLevelFlag
-> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings TopLevelFlag
TopLevel [(Var, CoreExpr)]
all_pairs (([Var] -> LintM ()) -> LintM ((), [UsageEnv]))
-> ([Var] -> LintM ()) -> LintM ((), [UsageEnv])
forall a b. (a -> b) -> a -> b
$ \[Var]
_ ->
         () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    all_pairs :: [(Var, CoreExpr)]
all_pairs = CoreProgram -> [(Var, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds
     -- Put all the top-level binders in scope at the start
     -- This is because rewrite rules can bring something
     -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"
    binders :: [Var]
binders = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
all_pairs

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

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

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

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

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

-}

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

lintUnfolding :: Bool -> LintConfig -> SrcLoc -> CoreExpr -> Maybe (Bag SDoc)
lintUnfolding Bool
is_compulsory LintConfig
cfg SrcLoc
locn CoreExpr
expr
  | Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs = Maybe (Bag SDoc)
forall a. Maybe a
Nothing
  | Bool
otherwise       = Bag SDoc -> Maybe (Bag SDoc)
forall a. a -> Maybe a
Just Bag SDoc
errs
  where
    (Bag SDoc
_warns, Bag SDoc
errs) = LintConfig -> LintM (InType, UsageEnv) -> WarnsAndErrs
forall a. LintConfig -> LintM a -> WarnsAndErrs
initL LintConfig
cfg (LintM (InType, UsageEnv) -> WarnsAndErrs)
-> LintM (InType, UsageEnv) -> WarnsAndErrs
forall a b. (a -> b) -> a -> b
$
                     if Bool
is_compulsory
                       -- See Note [Checking for representation polymorphism]
                     then LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintM a -> LintM a
noFixedRuntimeRepChecks LintM (InType, UsageEnv)
linter
                     else LintM (InType, UsageEnv)
linter
    linter :: LintM (InType, UsageEnv)
linter = LintLocInfo -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (SrcLoc -> LintLocInfo
ImportedUnfolding SrcLoc
locn) (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$
             CoreExpr -> LintM (InType, 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 (InType, UsageEnv) -> WarnsAndErrs
forall a. LintConfig -> LintM a -> WarnsAndErrs
initL LintConfig
cfg LintM (InType, UsageEnv)
linter
    linter :: LintM (InType, UsageEnv)
linter = LintLocInfo -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
TopLevelBindings (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$
             CoreExpr -> LintM (InType, 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)]
                -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings :: forall a.
TopLevelFlag
-> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings TopLevelFlag
top_lvl [(Var, CoreExpr)]
pairs [Var] -> LintM a
thing_inside
  = TopLevelFlag
-> [Var]
-> ([Var] -> LintM (a, [UsageEnv]))
-> LintM (a, [UsageEnv])
forall a. TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
lintIdBndrs TopLevelFlag
top_lvl [Var]
bndrs (([Var] -> LintM (a, [UsageEnv])) -> LintM (a, [UsageEnv]))
-> ([Var] -> LintM (a, [UsageEnv])) -> LintM (a, [UsageEnv])
forall a b. (a -> b) -> a -> b
$ \ [Var]
bndrs' ->
    do { ues <- (Var -> CoreExpr -> LintM UsageEnv)
-> [Var] -> [CoreExpr] -> LintM [UsageEnv]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Var -> CoreExpr -> LintM UsageEnv
lint_pair [Var]
bndrs' [CoreExpr]
rhss
       ; a <- thing_inside bndrs'
       ; return (a, ues) }
  where
    ([Var]
bndrs, [CoreExpr]
rhss) = [(Var, CoreExpr)] -> ([Var], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, CoreExpr)]
pairs
    lint_pair :: Var -> CoreExpr -> LintM UsageEnv
lint_pair Var
bndr' CoreExpr
rhs
      = LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RhsOf Var
bndr') (LintM UsageEnv -> LintM UsageEnv)
-> LintM UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$
        do { (rhs_ty, ue) <- Var -> CoreExpr -> LintM (InType, UsageEnv)
lintRhs Var
bndr' CoreExpr
rhs         -- Check the rhs
           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty
           ; return ue }

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

lintLetBind :: TopLevelFlag -> RecFlag -> OutId
              -> CoreExpr -> OutType -> LintM ()
-- Binder's type, and the RHS, have already been linted
-- This function checks other invariants
lintLetBind :: TopLevelFlag -> RecFlag -> Var -> CoreExpr -> InType -> LintM ()
lintLetBind TopLevelFlag
top_lvl RecFlag
rec_flag Var
binder CoreExpr
rhs InType
rhs_ty
  = do { let binder_ty :: InType
binder_ty = Var -> InType
idType Var
binder
       ; InType -> InType -> SDoc -> LintM ()
ensureEqTys InType
binder_ty InType
rhs_ty (Var -> SDoc -> InType -> SDoc
mkRhsMsg Var
binder (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RHS") InType
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
|| InType -> Bool
mightBeLiftedType InType
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
&& InType
binder_ty HasCallStack => InType -> InType -> Bool
InType -> InType -> Bool
`eqType` InType
addrPrimTy)
                 Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
rhs)
           (Var -> SDoc
mkTopNonLitStrMsg Var
binder)

       ; flags <- LintM LintFlags
getLintFlags

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

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

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

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

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

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

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

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

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

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

-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
-- for join points, it skips the outer lambdas that take arguments to the
-- join point.
--
-- See Note [Checking StaticPtrs].
lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv)
-- NB: the Id can be Linted or not -- it's only used for
--     its OccInfo and join-pointer-hood
lintRhs :: Var -> CoreExpr -> LintM (InType, UsageEnv)
lintRhs Var
bndr CoreExpr
rhs
    | JoinPoint JoinArity
arity <- Var -> JoinPointHood
idJoinPointHood Var
bndr
    = JoinArity -> Maybe Var -> CoreExpr -> LintM (InType, 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 (InType, 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 (InType, UsageEnv))
-> LintM (InType, 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 (InType, UsageEnv)
go
  where
    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
    -- otherwise.
    go :: StaticPtrCheck -> LintM (OutType, UsageEnv)
    go :: StaticPtrCheck -> LintM (InType, UsageEnv)
go StaticPtrCheck
AllowAtTopLevel
      | ([Var]
binders0, CoreExpr
rhs') <- CoreExpr -> ([Var], CoreExpr)
collectTyBinders CoreExpr
rhs
      , Just (CoreExpr
fun, InType
t, CoreExpr
info, CoreExpr
e) <- CoreExpr -> Maybe (CoreExpr, InType, CoreExpr, CoreExpr)
collectMakeStaticArgs CoreExpr
rhs'
      = LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$
        (Var -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> [Var] -> LintM (InType, 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 (InType, UsageEnv) -> LintM (InType, UsageEnv)
lintLambda
        -- imitate @lintCoreExpr (App ...)@
        (do fun_ty_ue <- CoreExpr -> LintM (InType, UsageEnv)
lintCoreExpr CoreExpr
fun
            lintCoreArgs fun_ty_ue [Type t, info, e]
        )
        [Var]
binders0
    go StaticPtrCheck
_ = LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (InType, 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 (OutType, UsageEnv)
lintJoinLams :: JoinArity -> Maybe Var -> CoreExpr -> LintM (InType, UsageEnv)
lintJoinLams JoinArity
join_arity Maybe Var
enforce CoreExpr
rhs
  = JoinArity -> CoreExpr -> LintM (InType, UsageEnv)
go JoinArity
join_arity CoreExpr
rhs
  where
    go :: JoinArity -> CoreExpr -> LintM (InType, UsageEnv)
go JoinArity
0 CoreExpr
expr            = CoreExpr -> LintM (InType, UsageEnv)
lintCoreExpr CoreExpr
expr
    go JoinArity
n (Lam Var
var CoreExpr
body)  = Var -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
lintLambda Var
var (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$ JoinArity -> CoreExpr -> LintM (InType, 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 (InType, UsageEnv)
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM (InType, UsageEnv))
-> SDoc -> LintM (InType, 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 (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (InType, UsageEnv)
lintCoreExpr CoreExpr
expr
                -- Body of lambda is not a tail position

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

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

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

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

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

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

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

Notice that

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

lintCoreExpr :: InExpr -> LintM (OutType, 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 (InType, UsageEnv)
lintCoreExpr (Var Var
var)
  = do {  var_pair@(var_ty, _) <- Var -> JoinArity -> LintM (InType, UsageEnv)
lintIdOcc Var
var JoinArity
0
           -- See Note [Linting representation-polymorphic builtins]
       ; checkRepPolyBuiltin (Var var) [] var_ty
           --checkDataToTagPrimOpTyCon (Var var) []
       ; return var_pair }

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

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

       ; lintCoercion co
       ; lintRole co Representational (coercionRole co)
       ; Pair from_ty to_ty <- substCoKindM co
       ; checkValueType (typeKind to_ty) $
         text "target of cast" <+> quotes (ppr co)
       ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty)
       ; return (to_ty, ue) }

lintCoreExpr (Tick CoreTickish
tickish CoreExpr
expr)
  = do { case CoreTickish
tickish of
           Breakpoint XBreakpoint 'TickishPassCore
_ JoinArity
_ [XTickishId 'TickishPassCore]
ids Module
_ -> [Var] -> (Var -> LintM (InType, UsageEnv)) -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Var]
[XTickishId 'TickishPassCore]
ids ((Var -> LintM (InType, UsageEnv)) -> LintM ())
-> (Var -> LintM (InType, UsageEnv)) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \Var
id -> Var -> JoinArity -> LintM (InType, UsageEnv)
lintIdOcc Var
id JoinArity
0
           CoreTickish
_                    -> () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       ; Bool -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. Bool -> LintM a -> LintM a
markAllJoinsBadIf Bool
block_joins (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (InType, 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 InType
ty)) CoreExpr
body)
  | Var -> Bool
isTyVar Var
tv
  =     -- See Note [Linting type lets]
    do  { ty' <- InType -> LintM InType
lintTypeAndSubst InType
ty
        ; lintTyCoBndr tv              $ \ Var
tv' ->
    do  { LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RhsOf Var
tv) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ Var -> InType -> LintM ()
lintTyKind Var
tv' InType
ty'
                -- Now extend the substitution so we
                -- take advantage of it in the body
        ; Var
-> InType -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. Var -> InType -> LintM a -> LintM a
extendTvSubstL Var
tv InType
ty' (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$
          LintLocInfo -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
BodyOfLet Var
tv) (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> LintM (InType, UsageEnv)
lintCoreExpr CoreExpr
body } }

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

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

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

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

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

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

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

lintCoreExpr e :: CoreExpr
e@(App CoreExpr
_ CoreExpr
_)
  | Var Var
fun <- CoreExpr
fun
  , Var
fun Var -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
    -- See Note [Linting of runRW#]
    -- N.B. we may have an over-saturated application of the form:
    --   runRW (\s -> \x -> ...) y
  , CoreExpr
ty_arg1 : CoreExpr
ty_arg2 : CoreExpr
cont_arg : [CoreExpr]
rest <- [CoreExpr]
args
  = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)
             lint_rw_cont :: CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv)
lint_rw_cont expr :: CoreExpr
expr@(Lam Var
_ CoreExpr
_) InType
mult UsageEnv
fun_ue
                = do { (arg_ty, arg_ue) <- JoinArity -> Maybe Var -> CoreExpr -> LintM (InType, UsageEnv)
lintJoinLams JoinArity
1 (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
fun) CoreExpr
expr
                     ; let app_ue = UsageEnv -> UsageEnv -> UsageEnv
addUE UsageEnv
fun_ue (InType -> UsageEnv -> UsageEnv
scaleUE InType
mult UsageEnv
arg_ue)
                     ; return (arg_ty, app_ue) }

             lint_rw_cont CoreExpr
expr InType
mult UsageEnv
ue
                = CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv)
lintValArg CoreExpr
expr InType
mult UsageEnv
ue
             -- TODO: Look through ticks?

       ; runrw_pr <- SDoc
-> (CoreExpr -> LintM InType)
-> (CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv))
-> InType
-> [CoreExpr]
-> UsageEnv
-> LintM (InType, UsageEnv)
forall in_a acc.
Outputable in_a =>
SDoc
-> (in_a -> LintM InType)
-> (in_a -> InType -> acc -> LintM (InType, acc))
-> InType
-> [in_a]
-> acc
-> LintM (InType, acc)
lintApp (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"runRW# expression")
                               CoreExpr -> LintM InType
lintTyArg CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv)
lint_rw_cont
                               (Var -> InType
idType Var
fun) [CoreExpr
ty_arg1,CoreExpr
ty_arg2,CoreExpr
cont_arg] UsageEnv
zeroUE
       ; lintCoreArgs runrw_pr rest }

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

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

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

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

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

-- This case can't happen; linting types in expressions gets routed through lintTyArg
lintCoreExpr (Type InType
ty)
  = SDoc -> LintM (InType, 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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty)

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

----------------------
lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed
          -> LintM (OutType, UsageEnv) -- returns type of the *variable*
lintIdOcc :: Var -> JoinArity -> LintM (InType, UsageEnv)
lintIdOcc Var
in_id JoinArity
nargs
  = LintLocInfo -> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
OccOf Var
in_id) (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$
    do  { Bool -> SDoc -> LintM ()
checkL (Var -> Bool
isNonCoVarId Var
in_id)
                 (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
in_id)
                 -- 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
        ; out_ty <- Var -> LintM InType
lintVarOcc Var
in_id

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

        ; checkDeadIdOcc in_id

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

        ; checkJoinOcc in_id nargs
        ; usage <- varCallSiteUsage in_id

        ; return (out_ty, usage) }



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

------------------
lintJoinBndrType :: OutType -- Type of the body
                 -> OutId   -- 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 :: InType -> Var -> LintM ()
lintJoinBndrType InType
body_ty Var
bndr
  | JoinPoint JoinArity
arity <- Var -> JoinPointHood
idJoinPointHood Var
bndr
  , let bndr_ty :: InType
bndr_ty = Var -> InType
idType Var
bndr
  , ([PiTyBinder]
bndrs, InType
res) <- InType -> ([PiTyBinder], InType)
splitPiTys InType
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
&& InType
body_ty HasCallStack => InType -> InType -> Bool
InType -> InType -> Bool
`eqType` [PiTyBinder] -> InType -> InType
HasDebugCallStack => [PiTyBinder] -> InType -> InType
mkPiTys (JoinArity -> [PiTyBinder] -> [PiTyBinder]
forall a. JoinArity -> [a] -> [a]
drop JoinArity
arity [PiTyBinder]
bndrs) InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
body_ty ])
  | Bool
otherwise
  = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

           JoinPoint JoinArity
join_arity_bndr ->

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

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

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

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

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

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

checkDataToTagPrimOpTyCon _ _ = pure ()
-}

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

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

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

  where

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

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

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

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

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

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

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

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

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

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

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

-- Check that the usage of var is consistent with var itself, and pop the var
-- from the usage environment (this is important because of shadowing).
checkLinearity :: UsageEnv -> OutVar -> LintM UsageEnv
checkLinearity :: UsageEnv -> Var -> LintM UsageEnv
checkLinearity UsageEnv
body_ue Var
lam_var =
  case Var -> Maybe InType
varMultMaybe Var
lam_var of
    Just InType
mult -> do
      let (Usage
lhs, UsageEnv
body_ue') = UsageEnv -> Var -> (Usage, UsageEnv)
forall n. NamedThing n => UsageEnv -> n -> (Usage, UsageEnv)
popUE UsageEnv
body_ue Var
lam_var
          err_msg :: SDoc
err_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ 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
                         , 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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
mult
                         , UsageEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr UsageEnv
body_ue ]
      Usage -> InType -> SDoc -> LintM ()
ensureSubUsage Usage
lhs InType
mult SDoc
err_msg
      UsageEnv -> LintM UsageEnv
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return UsageEnv
body_ue'
    Maybe InType
Nothing    -> UsageEnv -> LintM UsageEnv
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return UsageEnv
body_ue -- A type variable

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

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

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

and consider the expression

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

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

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

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

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

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

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

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

For example, suppose we have (comment 8)

  data T a where
    TInt :: T Int

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

  data Foo = Foo !(T Bool)

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

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

  absurdFoo (Foo x) = case x of

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

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


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

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

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

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

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

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

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

-- Takes the functions type and arguments as argument.
-- Returns the *result* of applying the function to arguments.
-- e.g. f :: Int -> Bool -> Int would return `Int` as result type.
lintCoreArgs  :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv)
lintCoreArgs :: (InType, UsageEnv) -> [CoreExpr] -> LintM (InType, UsageEnv)
lintCoreArgs (InType
fun_ty, UsageEnv
fun_ue) [CoreExpr]
args
  = SDoc
-> (CoreExpr -> LintM InType)
-> (CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv))
-> InType
-> [CoreExpr]
-> UsageEnv
-> LintM (InType, UsageEnv)
forall in_a acc.
Outputable in_a =>
SDoc
-> (in_a -> LintM InType)
-> (in_a -> InType -> acc -> LintM (InType, acc))
-> InType
-> [in_a]
-> acc
-> LintM (InType, acc)
lintApp (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expression")
              CoreExpr -> LintM InType
lintTyArg CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv)
lintValArg InType
fun_ty [CoreExpr]
args UsageEnv
fun_ue

lintTyArg :: InExpr -> LintM OutType

-- Type argument
lintTyArg :: CoreExpr -> LintM InType
lintTyArg (Type InType
arg_ty)
  = do { Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (InType -> Bool
isCoercionTy InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
arg_ty)
       ; InType -> LintM InType
lintTypeAndSubst InType
arg_ty }
lintTyArg CoreExpr
arg
  = SDoc -> LintM InType
forall a. SDoc -> LintM a
failWithL (SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Expected type argument but found") JoinArity
2 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg))

lintValArg  :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)
lintValArg :: CoreExpr -> InType -> UsageEnv -> LintM (InType, UsageEnv)
lintValArg CoreExpr
arg InType
mult UsageEnv
fun_ue
  = do { (arg_ty, arg_ue) <- LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (InType, UsageEnv) -> LintM (InType, UsageEnv))
-> LintM (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (InType, UsageEnv)
lintCoreExpr CoreExpr
arg
           -- See Note [Representation polymorphism invariants] in GHC.Core

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

       ; let app_ue = UsageEnv -> UsageEnv -> UsageEnv
addUE UsageEnv
fun_ue (InType -> UsageEnv -> UsageEnv
scaleUE InType
mult UsageEnv
arg_ue)
       ; return (arg_ty, app_ue) }

-----------------
lintAltBinders :: UsageEnv
               -> Var         -- Case binder
               -> OutType     -- Scrutinee type
               -> OutType     -- 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 -> InType -> InType -> [(InType, Var)] -> LintM UsageEnv
lintAltBinders UsageEnv
rhs_ue Var
_case_bndr InType
scrut_ty InType
con_ty []
  = do { InType -> InType -> SDoc -> LintM ()
ensureEqTys InType
con_ty InType
scrut_ty (InType -> InType -> SDoc
mkBadPatMsg InType
con_ty InType
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 InType
scrut_ty InType
con_ty ((InType
var_w, Var
bndr):[(InType, Var)]
bndrs)
  | Var -> Bool
isTyVar Var
bndr
  = do { con_ty' <- InType -> InType -> LintM InType
lintTyApp InType
con_ty (Var -> InType
mkTyVarTy Var
bndr)
       ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty'  bndrs }
  | Bool
otherwise
  = do { (con_ty', _) <- CoreExpr
-> InType
-> InType
-> UsageEnv
-> UsageEnv
-> LintM (InType, UsageEnv)
lintValApp (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
bndr) InType
con_ty (Var -> InType
idType Var
bndr) UsageEnv
zeroUE UsageEnv
zeroUE
         -- We can pass zeroUE to lintValApp because we ignore its usage
         -- calculation and compute it in the call for checkCaseLinearity below.
       ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr
       ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }

-- | Implements the case rules for linearity
checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv
checkCaseLinearity :: UsageEnv -> Var -> InType -> Var -> LintM UsageEnv
checkCaseLinearity UsageEnv
ue Var
case_bndr InType
var_w Var
bndr = do
  Usage -> InType -> SDoc -> LintM ()
ensureSubUsage Usage
lhs InType
rhs SDoc
err_msg
  SDoc -> InType -> InType -> LintM ()
lintLinearBinder (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr) (InType
case_bndr_w InType -> InType -> InType
`mkMultMul` InType
var_w) (HasDebugCallStack => Var -> InType
Var -> InType
idMult 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` (InType
var_w InType -> Usage -> Usage
`scaleUsage` Usage
case_bndr_usage)
    rhs :: InType
rhs = InType
case_bndr_w InType -> InType -> InType
`mkMultMul` InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
var_w)
    rhs_formula :: SDoc
rhs_formula = InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
var_w
    case_bndr_w :: InType
case_bndr_w = HasDebugCallStack => Var -> InType
Var -> InType
idMult 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 :: OutType -> OutType -> LintM OutType
lintTyApp :: InType -> InType -> LintM InType
lintTyApp InType
fun_ty InType
arg_ty
  | Just (Var
tv,InType
body_ty) <- InType -> Maybe (Var, InType)
splitForAllTyVar_maybe InType
fun_ty
  = do  { Var -> InType -> LintM ()
lintTyKind Var
tv InType
arg_ty
        ; in_scope <- LintM InScopeSet
getInScope
        -- substTy needs the set of tyvars in scope to avoid generating
        -- uniques that are already in scope.
        -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst
        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }

  | Bool
otherwise
  = SDoc -> LintM InType
forall a. SDoc -> LintM a
failWithL (InType -> InType -> SDoc
mkTyAppMsg InType
fun_ty InType
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 -> OutType -> OutType -> UsageEnv -> UsageEnv
           -> LintM (OutType, UsageEnv)
lintValApp :: CoreExpr
-> InType
-> InType
-> UsageEnv
-> UsageEnv
-> LintM (InType, UsageEnv)
lintValApp CoreExpr
arg InType
fun_ty InType
arg_ty UsageEnv
fun_ue UsageEnv
arg_ue
  | Just (FunTyFlag
_, InType
w, InType
arg_ty', InType
res_ty') <- InType -> Maybe (FunTyFlag, InType, InType, InType)
splitFunTy_maybe InType
fun_ty
  = do { InType -> InType -> SDoc -> LintM ()
ensureEqTys InType
arg_ty' InType
arg_ty (InType -> InType -> CoreExpr -> SDoc
mkAppMsg InType
arg_ty' InType
arg_ty CoreExpr
arg)
       ; let app_ue :: UsageEnv
app_ue =  UsageEnv -> UsageEnv -> UsageEnv
addUE UsageEnv
fun_ue (InType -> UsageEnv -> UsageEnv
scaleUE InType
w UsageEnv
arg_ue)
       ; (InType, UsageEnv) -> LintM (InType, UsageEnv)
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (InType
res_ty', UsageEnv
app_ue) }
  | Bool
otherwise
  = SDoc -> LintM (InType, UsageEnv)
forall a. SDoc -> LintM a
failWithL SDoc
err2
  where
    err2 :: SDoc
err2 = InType -> InType -> CoreExpr -> SDoc
mkNonFunAppMsg InType
fun_ty InType
arg_ty CoreExpr
arg

lintTyKind :: OutTyVar -> OutType -> 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 -> InType -> LintM ()
lintTyKind Var
tyvar InType
arg_ty
  = Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (InType
arg_kind HasCallStack => InType -> InType -> Bool
InType -> InType -> Bool
`eqType` InType
tyvar_kind) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
    SDoc -> LintM ()
addErrL (Var -> InType -> SDoc
mkKindErrMsg Var
tyvar InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
arg_kind))
  where
    tyvar_kind :: InType
tyvar_kind = Var -> InType
tyVarKind Var
tyvar
    arg_kind :: InType
arg_kind   = HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
arg_ty

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

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

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

       ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty

       ; checkCaseAlts e scrut scrut_ty' alts

       -- Lint the case-binder. Must do this after linting the scrutinee
       -- because the case-binder isn't in scope in the scrutineex
       ; lintBinder CaseBind case_bndr $ \Var
case_bndr' ->
      -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate

    do { let case_bndr_ty' :: InType
case_bndr_ty' = Var -> InType
idType Var
case_bndr'
             scrut_mult :: InType
scrut_mult    = HasDebugCallStack => Var -> InType
Var -> InType
idMult Var
case_bndr'

       ; InType -> InType -> SDoc -> LintM ()
ensureEqTys InType
case_bndr_ty' InType
scrut_ty' (Var -> InType -> InType -> SDoc
mkScrutMsg Var
case_bndr InType
case_bndr_ty' InType
scrut_ty')
         -- See GHC.Core Note [Case expression invariants] item (7)

       ; -- Check the alternatives
       ; alt_ues <- (Alt Var -> LintM UsageEnv) -> [Alt Var] -> LintM [UsageEnv]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Var -> InType -> InType -> InType -> Alt Var -> LintM UsageEnv
lintCoreAlt Var
case_bndr' InType
scrut_ty' InType
scrut_mult InType
alt_ty') [Alt Var]
alts
       ; let case_ue = (InType -> UsageEnv -> UsageEnv
scaleUE InType
scrut_mult UsageEnv
scrut_ue) UsageEnv -> UsageEnv -> UsageEnv
`addUE` [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
alt_ues
       ; return (alt_ty', case_ue) } }

checkCaseAlts :: InExpr -> InExpr -> OutType -> [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
-- d) Check that the scrutinee is not a floating-point type
--    if there are any literal alternatives
-- e) Check if the scrutinee type has no constructors
--
-- 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.
--
-- NB: Algebraic cases are not necessarily exhaustive, because
--     the simplifier correctly eliminates case that can't
--     possibly match.
checkCaseAlts :: CoreExpr -> CoreExpr -> InType -> [Alt Var] -> LintM ()
checkCaseAlts CoreExpr
e CoreExpr
scrut InType
scrut_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)

       -- 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
       ; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ InType -> Bool
isFloatingPrimTy InType
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
is_lit_alt [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)

       -- Check if scrutinee type has no constructors
       -- Just a trace message for now
       ; case InType -> Maybe TyCon
tyConAppTyCon_maybe InType
scrut_ty 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 scrutinee type has no constructors"
                        (InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
scrut_ty)
                          -- 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 ()
        }
  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_lit_alt :: Alt b -> Bool
is_lit_alt (Alt (LitAlt Literal
_) [b]
_  Expr b
_) = Bool
True
    is_lit_alt Alt b
_                     = Bool
False

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

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

lintCoreAlt :: OutId         -- Case binder
            -> OutType       -- Type of scrutinee
            -> Mult          -- Multiplicity of scrutinee
            -> OutType       -- 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 -> InType -> InType -> InType -> Alt Var -> LintM UsageEnv
lintCoreAlt Var
case_bndr InType
_ InType
scrut_mult InType
alt_ty (Alt AltCon
DEFAULT [Var]
args CoreExpr
rhs) =
  do { Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
args) ([Var] -> SDoc
mkDefaultArgsMsg [Var]
args)
     ; rhs_ue <- CoreExpr -> InType -> LintM UsageEnv
lintAltExpr CoreExpr
rhs InType
alt_ty
     ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr
           err_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Linearity failure in the DEFAULT clause:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
case_bndr
                          , 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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
scrut_mult ]
     ; ensureSubUsage case_bndr_usage scrut_mult err_msg
     ; return rhs_ue' }

lintCoreAlt Var
case_bndr InType
scrut_ty InType
_ InType
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)
       ; InType -> InType -> SDoc -> LintM ()
ensureEqTys InType
lit_ty InType
scrut_ty (InType -> InType -> SDoc
mkBadPatMsg InType
lit_ty InType
scrut_ty)
       ; rhs_ue <- CoreExpr -> InType -> LintM UsageEnv
lintAltExpr CoreExpr
rhs InType
alt_ty
       ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks
       }
  where
    lit_ty :: InType
lit_ty = Literal -> InType
literalType Literal
lit

lintCoreAlt Var
case_bndr InType
scrut_ty InType
_scrut_mult InType
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 (InType -> Alt Var -> SDoc
mkNewTyDataConAltMsg InType
scrut_ty Alt Var
alt)
  | Just (TyCon
tycon, [InType]
tycon_arg_tys) <- HasDebugCallStack => InType -> Maybe (TyCon, [InType])
InType -> Maybe (TyCon, [InType])
splitTyConApp_maybe InType
scrut_ty
  = LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Alt Var -> LintLocInfo
CaseAlt Alt Var
alt) (LintM UsageEnv -> LintM UsageEnv)
-> LintM UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$  do
    { String -> DataCon -> LintM ()
checkTypeDataConOcc String
"pattern" DataCon
con
    ; Bool -> SDoc -> LintM ()
lintL (TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
con) (TyCon -> DataCon -> SDoc
mkBadConMsg TyCon
tycon DataCon
con)

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

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

  | Bool
otherwise   -- Scrut-ty is wrong shape
  = UsageEnv
zeroUE UsageEnv -> LintM () -> LintM UsageEnv
forall a b. a -> LintM b -> LintM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SDoc -> LintM ()
addErrL (InType -> Alt Var -> SDoc
mkBadAltMsg InType
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 -> InType -> InType -> LintM ()
lintLinearBinder SDoc
doc InType
actual_usage InType
described_usage
  = InType -> InType -> SDoc -> LintM ()
ensureSubMult InType
actual_usage InType
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
$$ InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
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 :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a
lintBinders :: forall a.
HasDebugCallStack =>
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.
HasDebugCallStack =>
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.
HasDebugCallStack =>
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 :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a
lintBinder :: forall a.
HasDebugCallStack =>
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. HasDebugCallStack => 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

lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a
lintTyCoBndr :: forall a. HasDebugCallStack => Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr Var
tcv Var -> LintM a
thing_inside
  = do { tcv_type' <- InType -> LintM InType
lintTypeAndSubst (Var -> InType
varType Var
tcv)
       ; let tcv_kind' = HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
tcv_type'

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

       ; addInScopeTyCoVar tcv tcv_type' thing_inside }

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

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

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

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

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

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

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

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

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

       ; addInScopeId id out_ty thing_inside }
  where
    id_ty :: InType
id_ty = Var -> InType
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
%*                                                                      *
%************************************************************************
-}

{- Note [Linting types and coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that
   lintType     :: InType     -> LintM ()
   lintCoercion :: InCoercion -> LintM ()
Neither returns anything.

If you need the kind of the type, then do `typeKind` and then apply
the ambient substitution using `substTyM`.  Note that the substitution
empty unless there is shadowing or type-lets; and if the substitution is
empty, the `substTyM` is a no-op.

It is better to take the kind and then substitute, rather than substitute
and then take the kind, becaues the kind is usually smaller.

Note: you might wonder if we should apply the same logic to expressions.
Why do we have
  lintExpr :: InExpr -> LintM OutType
Partly inertia; but also taking the type of an expresison involve looking
down a deep chain of let's, whereas that is not true of taking the kind
of a type.  It'd be worth an experiment though.

Historical note: in the olden days we had
   lintType :: InType -> LintM OutType
but that burned a huge amount of allocation building an OutType that was
often discarded, or used only to get its kind.

I also experimented with
   lintType :: InType -> LintM OutKind
but that too was slower.  It is also much simpler to return ()!  If we
return the kind we have to duplicate the logic in `typeKind`; and it is
much worse for coercions.
-}

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

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

-------------------
lintTypeAndSubst :: InType -> LintM OutType
lintTypeAndSubst :: InType -> LintM InType
lintTypeAndSubst InType
ty = do { InType -> LintM ()
lintType InType
ty; InType -> LintM InType
substTyM InType
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

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

  | Bool
otherwise
  = do { _ <- Var -> LintM InType
lintVarOcc Var
tv
       ; return () }

lintType ty :: InType
ty@(AppTy InType
t1 InType
t2)
  | TyConApp {} <- InType
t1
  = SDoc -> LintM ()
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM ()) -> SDoc -> LintM ()
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty
  | Bool
otherwise
  = do { let (InType
fun_ty, [InType]
arg_tys) = InType -> [InType] -> (InType, [InType])
collect InType
t1 [InType
t2]
       ; InType -> LintM ()
lintType InType
fun_ty
       ; fun_kind <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
fun_ty)
       ; lint_ty_app ty fun_kind arg_tys }
  where
    collect :: InType -> [InType] -> (InType, [InType])
collect (AppTy InType
f InType
a) [InType]
as = InType -> [InType] -> (InType, [InType])
collect InType
f (InType
aInType -> [InType] -> [InType]
forall a. a -> [a] -> [a]
:[InType]
as)
    collect InType
fun         [InType]
as = (InType
fun, [InType]
as)

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

  | Just {} <- HasDebugCallStack => TyCon -> [InType] -> Maybe InType
TyCon -> [InType] -> Maybe InType
tyConAppFunTy_maybe TyCon
tc [InType]
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 ()
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 (InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty))

  | Bool
otherwise  -- Data types, data families, primitive types
  = do { TyCon -> LintM ()
checkTyCon TyCon
tc
       ; InType -> InType -> [InType] -> LintM ()
lint_ty_app InType
ty (TyCon -> InType
tyConKind TyCon
tc) [InType]
tys }

-- arrows can related *unlifted* kinds, so this has to be separate from
-- a dependent forall.
lintType ty :: InType
ty@(FunTy FunTyFlag
af InType
tw InType
t1 InType
t2)
  = do { InType -> LintM ()
lintType InType
t1
       ; InType -> LintM ()
lintType InType
t2
       ; InType -> LintM ()
lintType InType
tw
       ; SDoc -> FunTyFlag -> InType -> InType -> InType -> 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 (InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty)) FunTyFlag
af InType
t1 InType
t2 InType
tw }

lintType ty :: InType
ty@(ForAllTy {})
  = [Var] -> InType -> LintM ()
go [] InType
ty
  where
    go :: [OutTyCoVar] -> InType -> LintM ()
    -- Loop, collecting the forall-binders
    go :: [Var] -> InType -> LintM ()
go [Var]
tcvs ty :: InType
ty@(ForAllTy (Bndr Var
tcv ForAllTyFlag
_) InType
body_ty)
      | Bool -> Bool
not (Var -> Bool
isTyCoVar Var
tcv)
      = SDoc -> LintM ()
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty)

      | Bool
otherwise
      = Var -> (Var -> LintM ()) -> LintM ()
forall a. HasDebugCallStack => Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr Var
tcv ((Var -> LintM ()) -> LintM ()) -> (Var -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \Var
tcv' ->
        do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]
             -- Suspicious because it works on InTyCoVar; c.f. ForAllCo
             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 -> Bool) -> InType -> Bool
anyFreeVarsOfType (Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
tcv) InType
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
$$ InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
body_ty)

           ; [Var] -> InType -> LintM ()
go (Var
tcv' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
tcvs) InType
body_ty }

    go [Var]
tcvs InType
body_ty
      = do { InType -> LintM ()
lintType InType
body_ty
           ; [Var] -> InType -> LintM ()
lintForAllBody [Var]
tcvs InType
body_ty }

lintType (CastTy InType
ty Coercion
co)
  = do { InType -> LintM ()
lintType InType
ty
       ; ty_kind <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
ty)
       ; co_lk <- lintStarCoercion co
       ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) }

lintType (LitTy TyLit
l)       = TyLit -> LintM ()
lintTyLit TyLit
l
lintType (CoercionTy Coercion
co) = HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co

-----------------
lintForAllBody :: [OutTyCoVar] -> InType -> LintM ()
-- Do the checks for the body of a forall-type
lintForAllBody :: [Var] -> InType -> LintM ()
lintForAllBody [Var]
tcvs InType
body_ty
  = do { -- 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
         body_kind <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
body_ty)
       ; case occCheckExpand tcvs body_kind of
           Just {} -> () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Maybe InType
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
"tycovars (reversed):" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
tcvs
                                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
body_ty
                                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"kind:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
body_kind ])
       ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) }

-----------------
lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM ()
-- 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 -> InType -> TyCon -> [InType] -> LintM ()
lintTySynFamApp Bool
report_unsat InType
ty TyCon
tc [InType]
tys
  | Bool
report_unsat   -- Report unsaturated only if report_unsat is on
  , [InType]
tys [InType] -> JoinArity -> Bool
forall a. [a] -> JoinArity -> Bool
`lengthLessThan` TyCon -> JoinArity
tyConArity TyCon
tc
  = SDoc -> LintM ()
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 (InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty))

  -- Deal with type synonyms
  | ExpandsSyn [(Var, InType)]
tenv InType
rhs [InType]
tys' <- TyCon -> [InType] -> ExpandSynResult InType
forall tyco. TyCon -> [tyco] -> ExpandSynResult tyco
expandSynTyCon_maybe TyCon
tc [InType]
tys
  , let expanded_ty :: InType
expanded_ty = InType -> [InType] -> InType
mkAppTys (HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy ([(Var, InType)] -> Subst
mkTvSubstPrs [(Var, InType)]
tenv) InType
rhs) [InType]
tys'
  = do { 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 { _ <- InType -> LintM ()
lintType InType
expanded_ty
                                ; return () }

       ; -- Kind-check the argument types, but without reporting
         -- un-saturated type families/synonyms
       ; Bool -> LintM () -> LintM ()
forall a. Bool -> LintM a -> LintM a
setReportUnsat Bool
False (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
         InType -> InType -> [InType] -> LintM ()
lint_ty_app InType
ty (TyCon -> InType
tyConKind TyCon
tc) [InType]
tys }

  -- Otherwise this must be a type family
  | Bool
otherwise
  = InType -> InType -> [InType] -> LintM ()
lint_ty_app InType
ty (TyCon -> InType
tyConKind TyCon
tc) [InType]
tys

-----------------
-- Confirms that a kind is really TYPE r or Constraint
checkValueType :: OutKind -> SDoc -> LintM ()
checkValueType :: InType -> SDoc -> LintM ()
checkValueType InType
kind SDoc
doc
  = Bool -> SDoc -> LintM ()
lintL (InType -> Bool
isTYPEorCONSTRAINT InType
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
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)

-----------------
lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM ()
lintArrow SDoc
what FunTyFlag
af InType
t1 InType
t2 InType
tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw
                            -- or lintArrow "coercion `blah'" k1 k2 kw
  = do { k1 <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
t1)
       ; k2 <- substTyM (typeKind t2)
       ; kw <- substTyM (typeKind tw)
       ; unless (isTYPEorCONSTRAINT k1) (report (text "argument")     t1 k1)
       ; unless (isTYPEorCONSTRAINT k2) (report (text "result")       t2 k2)
       ; unless (isMultiplicityTy kw)   (report (text "multiplicity") tw kw)

       ; let real_af = HasDebugCallStack => InType -> InType -> FunTyFlag
InType -> InType -> FunTyFlag
chooseFunTyFlag InType
t1 InType
t2
       ; unless (real_af == af) $ addErrL $
         hang (text "Bad FunTyFlag")
            2 (vcat [ text "FunTyFlag =" <+> ppr af
                    , text "Computed FunTyFlag =" <+> ppr real_af
                    , text "in" <+> what ]) }
  where
    report :: SDoc -> InType -> InType -> LintM ()
report SDoc
ar InType
t InType
k = SDoc -> LintM ()
addErrL (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 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
k
                                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what ]))

-----------------
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_ty_app :: InType -> OutKind -> [InType] -> LintM ()
lint_ty_app :: InType -> InType -> [InType] -> LintM ()
lint_ty_app InType
ty = SDoc -> InType -> [InType] -> LintM ()
lint_tyco_app (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty))

lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM ()
lint_co_app :: HasDebugCallStack => Coercion -> InType -> [InType] -> LintM ()
lint_co_app Coercion
co = SDoc -> InType -> [InType] -> LintM ()
lint_tyco_app (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
co))

lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM ()
lint_tyco_app :: SDoc -> InType -> [InType] -> LintM ()
lint_tyco_app SDoc
msg InType
fun_kind [InType]
arg_tys
    -- See Note [Avoiding compiler perf traps when constructing error messages.]
  = do { _ <- SDoc
-> (InType -> LintM InType)
-> (InType -> InType -> () -> LintM (InType, ()))
-> InType
-> [InType]
-> ()
-> LintM (InType, ())
forall in_a acc.
Outputable in_a =>
SDoc
-> (in_a -> LintM InType)
-> (in_a -> InType -> acc -> LintM (InType, acc))
-> InType
-> [in_a]
-> acc
-> LintM (InType, acc)
lintApp SDoc
msg (\InType
ty     -> do { InType -> LintM ()
lintType InType
ty; InType -> LintM InType
substTyM InType
ty })
                            (\InType
ty InType
_ ()
_ -> do { InType -> LintM ()
lintType InType
ty; ki <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
ty); return (ki,()) })
                            InType
fun_kind [InType]
arg_tys ()
       ; return () }

----------------
lintApp :: forall in_a acc. Outputable in_a =>
             SDoc
          -> (in_a -> LintM OutType)                        -- Lint the thing and return its value
          -> (in_a -> Mult -> acc -> LintM (OutKind, acc))  -- Lint the thing and return its type
          -> OutType
          -> [in_a]                               -- The arguments, always "In" things
          -> acc                                  -- Used (only) for UsageEnv in /term/ applications
          -> LintM (OutType,acc)
-- lintApp is a performance-critical function, which deals with multiple
-- applications such as  (/\a./\b./\c. expr) @ta @tb @tc
-- When returning the type of this expression we want to avoid substituting a:=ta,
-- and /then/ substituting b:=tb, etc.  That's quadratic, and can be a huge
-- perf hole.  So we gather all the arguments [in_a], and then gather the
-- substitution incrementally in the `go` loop.
--
-- lintApp is used:
--    * for term applications (lintCoreArgs)
--    * for type applications (lint_ty_app)
--    * for coercion application (lint_co_app)
-- To deal with these cases `lintApp` has two higher order arguments;
-- but we specialise it for each call site (by inlining)
{-# INLINE lintApp #-}    -- INLINE: very few call sites;
                          -- not recursive; specialised at its call sites

lintApp :: forall in_a acc.
Outputable in_a =>
SDoc
-> (in_a -> LintM InType)
-> (in_a -> InType -> acc -> LintM (InType, acc))
-> InType
-> [in_a]
-> acc
-> LintM (InType, acc)
lintApp SDoc
msg in_a -> LintM InType
lint_forall_arg in_a -> InType -> acc -> LintM (InType, acc)
lint_arrow_arg !InType
orig_fun_ty [in_a]
all_args acc
acc
    = do { !in_scope <- LintM InScopeSet
getInScope
         -- We need the in_scope set to satisfy the invariant in
         -- Note [The substitution invariant] in GHC.Core.TyCo.Subst
         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.

         ; let init_subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope

               go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc)
                     -- The Subst applies (only) to the fun_ty
                     -- c.f. GHC.Core.Type.piResultTys, which has a similar loop

               go Subst
subst InType
fun_ty acc
acc []
                 = (InType, acc) -> LintM (InType, acc)
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy Subst
subst InType
fun_ty, acc
acc)

               go Subst
subst (ForAllTy (Bndr Var
tv ForAllTyFlag
_vis) InType
body_ty) acc
acc (in_a
arg:[in_a]
args)
                 = do { arg' <- in_a -> LintM InType
lint_forall_arg in_a
arg
                      ; let tv_kind = HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy Subst
subst (Var -> InType
varType Var
tv)
                            karg'   = HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
arg'
                            subst'  = Subst -> Var -> InType -> Subst
extendTCvSubst Subst
subst Var
tv InType
arg'
                      ; ensureEqTys karg' tv_kind $
                        lint_app_fail_msg msg orig_fun_ty all_args
                            (hang (text "Forall:" <+> (ppr tv $$ ppr tv_kind))
                                2 (ppr arg' <+> dcolon <+> ppr karg'))
                      ; go subst' body_ty acc args }

               go Subst
subst fun_ty :: InType
fun_ty@(FunTy FunTyFlag
_ InType
mult InType
exp_arg_ty InType
res_ty) acc
acc (in_a
arg:[in_a]
args)
                 = do { (arg_ty, acc') <- in_a -> InType -> acc -> LintM (InType, acc)
lint_arrow_arg in_a
arg (HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy Subst
subst InType
mult) acc
acc
                      ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $
                        lint_app_fail_msg msg orig_fun_ty all_args
                            (hang (text "Fun:" <+> ppr fun_ty)
                                2 (vcat [ text "exp_arg_ty:" <+> ppr exp_arg_ty
                                        , text "arg:" <+> ppr arg <+> dcolon <+> ppr arg_ty ]))
                      ; go subst res_ty acc' args }

               go Subst
subst InType
fun_ty acc
acc [in_a]
args
                 | Just InType
fun_ty' <- InType -> Maybe InType
coreView InType
fun_ty
                 = Subst -> InType -> acc -> [in_a] -> LintM (InType, acc)
go Subst
subst InType
fun_ty' acc
acc [in_a]
args

                 | Bool -> Bool
not (Subst -> Bool
isEmptyTCvSubst Subst
subst)  -- See Note [Care with kind instantiation]
                 = Subst -> InType -> acc -> [in_a] -> LintM (InType, acc)
go Subst
init_subst (HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy Subst
subst InType
fun_ty) acc
acc [in_a]
args

                 | Bool
otherwise
                 = SDoc -> LintM (InType, acc)
forall a. SDoc -> LintM a
failWithL (SDoc -> InType -> [in_a] -> SDoc -> SDoc
forall a2. Outputable a2 => SDoc -> InType -> a2 -> SDoc -> SDoc
lint_app_fail_msg SDoc
msg InType
orig_fun_ty [in_a]
all_args
                                  (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Not a fun:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
fun_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [in_a] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [in_a]
args)))

         ; go init_subst orig_fun_ty acc all_args }

-- 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 a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc
lint_app_fail_msg :: forall a2. Outputable a2 => SDoc -> InType -> a2 -> SDoc -> SDoc
lint_app_fail_msg SDoc
msg InType
kfn a2
arg_tys 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
"Application error in") JoinArity
2 SDoc
msg
         , JoinArity -> SDoc -> SDoc
nest JoinArity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Function type =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
kfn)
         , JoinArity -> SDoc -> SDoc
nest JoinArity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Args =" 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 -> OutType -> CoreRule -> LintM ()
lintCoreRule :: Var -> InType -> CoreRule -> LintM ()
lintCoreRule Var
_ InType
_ (BuiltinRule {})
  = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Don't bother

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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


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

substCoKindM :: InCoercion -> LintM (Pair OutType)
substCoKindM :: Coercion -> LintM (Pair InType)
substCoKindM Coercion
co
  = do { let !(Pair InType
lk InType
rk) = HasDebugCallStack => Coercion -> Pair InType
Coercion -> Pair InType
coercionKind Coercion
co
       ; lk' <- InType -> LintM InType
substTyM InType
lk
       ; rk' <- substTyM rk
       ; return (Pair lk' rk') }

lintCoercion :: HasDebugCallStack => InCoercion -> LintM ()
-- See Note [Linting types and coercions]
--
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]

lintCoercion :: HasDebugCallStack => Coercion -> LintM ()
lintCoercion (CoVarCo Var
cv)
  | Bool -> Bool
not (Var -> Bool
isCoVar Var
cv)
  = SDoc -> LintM ()
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
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> InType
varType Var
cv)))

  | Bool
otherwise  -- C.f. lintType (TyVarTy tv), which has better docs
  = do { _ <- Var -> LintM InType
lintVarOcc Var
cv; return () }

lintCoercion (Refl InType
ty)          = InType -> LintM ()
lintType InType
ty
lintCoercion (GRefl Role
_r InType
ty MCoercion
MRefl) = InType -> LintM ()
lintType InType
ty

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

lintCoercion co :: Coercion
co@(TyConAppCo Role
r TyCon
tc [Coercion]
cos)
  | Just {} <- HasDebugCallStack => Role -> TyCon -> [Coercion] -> Maybe Coercion
Role -> TyCon -> [Coercion] -> Maybe Coercion
tyConAppFunCo_maybe Role
r TyCon
tc [Coercion]
cos
  = SDoc -> LintM ()
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], InType)
synTyConDefn_maybe TyCon
tc
  = SDoc -> LintM ()
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 -> LintM ()) -> [Coercion] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion [Coercion]
cos
       ; let tc_kind :: InType
tc_kind = TyCon -> InType
tyConKind TyCon
tc
       ; HasDebugCallStack => Coercion -> InType -> [InType] -> LintM ()
Coercion -> InType -> [InType] -> LintM ()
lint_co_app Coercion
co InType
tc_kind ((Coercion -> InType) -> [Coercion] -> [InType]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Coercion -> InType
Coercion -> InType
coercionLKind [Coercion]
cos)
       ; HasDebugCallStack => Coercion -> InType -> [InType] -> LintM ()
Coercion -> InType -> [InType] -> LintM ()
lint_co_app Coercion
co InType
tc_kind ((Coercion -> InType) -> [Coercion] -> [InType]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Coercion -> InType
Coercion -> InType
coercionRKind [Coercion]
cos)
       ; (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) ((Coercion -> Role) -> [Coercion] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Role
coercionRole [Coercion]
cos) }


lintCoercion co :: Coercion
co@(AppCo Coercion
co1 Coercion
co2)
  | TyConAppCo {} <- Coercion
co1
  = SDoc -> LintM ()
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 (InType, Role)
isReflCo_maybe Coercion
co1
  = SDoc -> LintM ()
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 { HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co1
       ; HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co2
       ; let !(Pair InType
lt1 InType
rt1) = HasDebugCallStack => Coercion -> Pair InType
Coercion -> Pair InType
coercionKind Coercion
co1
       ; lk1 <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
lt1)
       ; rk1 <- substTyM (typeKind rt1)
       ; lint_co_app co lk1 [coercionLKind co2]
       ; lint_co_app co rk1 [coercionRKind co2]

       ; let r2 = Coercion -> Role
coercionRole Coercion
co2
       ; if coercionRole co1 == Phantom
         then lintL (r2 == Phantom || r2 == Nominal)
                     (text "Second argument in AppCo cannot be R:" $$
                      ppr co)
         else lintRole co Nominal r2 }

----------
lintCoercion co :: Coercion
co@(ForAllCo {})
-- See Note [ForAllCo] in GHC.Core.TyCo.Rep for the typing rule for ForAllCo
  = do { _ <- [Var] -> Coercion -> LintM Role
go [] Coercion
co; return () }
  where
    go :: [OutTyCoVar]   -- Binders in reverse order
       -> InCoercion -> LintM Role
    go :: [Var] -> Coercion -> LintM Role
go [Var]
tcvs co :: Coercion
co@(ForAllCo { fco_tcv :: Coercion -> Var
fco_tcv = Var
tcv, fco_visL :: Coercion -> ForAllTyFlag
fco_visL = ForAllTyFlag
visL, fco_visR :: Coercion -> ForAllTyFlag
fco_visR = ForAllTyFlag
visR
                         , fco_kind :: Coercion -> Coercion
fco_kind = Coercion
kind_co, fco_body :: Coercion -> Coercion
fco_body = Coercion
body_co })
      | Bool -> Bool
not (Var -> Bool
isTyCoVar Var
tcv)
      = SDoc -> LintM Role
forall a. SDoc -> LintM a
failWithL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Non tyco binder in ForAllCo:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)

      | Bool
otherwise
      = do { lk <- Coercion -> LintM InType
lintStarCoercion Coercion
kind_co
           ; lintTyCoBndr tcv $ \Var
tcv' ->
        do { InType -> InType -> SDoc -> LintM ()
ensureEqTys (Var -> InType
varType Var
tcv') InType
lk (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
             String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Kind mis-match in ForallCo" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co

           -- I'm not very sure about this part, because it traverses body_co
           -- but at least it's on a cold path (a ForallCo for a CoVar)
           -- Also it works on InTyCoVar and InCoercion, which is suspect
           ; 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
$
             do { Bool -> SDoc -> LintM ()
lintL (ForAllTyFlag
visL ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
coreTyLamForAllTyFlag Bool -> Bool -> Bool
&& ForAllTyFlag
visR ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
coreTyLamForAllTyFlag) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Invalid visibility flags in CoVar ForAllCo" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
                  -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep
                ; Bool -> SDoc -> LintM ()
lintL (Var -> Coercion -> Bool
almostDevoidCoVarOfCo Var
tcv Coercion
body_co) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Covar can only appear in Refl and GRefl: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co }
                  -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep

           ; role <- [Var] -> Coercion -> LintM Role
go (Var
tcv'Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
tcvs) Coercion
body_co

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

           ; return role } }

    go [Var]
tcvs Coercion
body_co
      = do { HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
body_co

           -- Need to check that
           --    (forall (tcv:k1). lty) and
           --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])
           -- are both well formed, including the skolem escape check.
           -- Easiest way is to call lintForAllBody for each
           ; let Pair InType
lty InType
rty = HasDebugCallStack => Coercion -> Pair InType
Coercion -> Pair InType
coercionKind Coercion
body_co
           ; [Var] -> InType -> LintM ()
lintForAllBody [Var]
tcvs InType
lty
           ; [Var] -> InType -> LintM ()
lintForAllBody [Var]
tcvs InType
rty

           ; Role -> LintM Role
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Role
coercionRole Coercion
body_co) }


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

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

       -- Check the to and from types
       ; InType -> LintM ()
lintType InType
ty1
       ; InType -> LintM ()
lintType InType
ty2
       ; tk1 <- InType -> LintM InType
substTyM (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
ty1)
       ; tk2 <- substTyM (typeKind ty2)

       ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2)
              (checkTypes ty1 ty2)

       -- Check the coercions on which this UnivCo depends
       ; mapM_ lintCoercion deps }
   where
     report :: String -> SDoc
report String
s = SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Unsafe coercion: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
                     JoinArity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"From:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty1
                             , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  To:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
ty2])
     isUnBoxed :: PrimRep -> Bool
     isUnBoxed :: PrimRep -> Bool
isUnBoxed = Bool -> Bool
not (Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> Bool
isGcPtrRep

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

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

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

lintCoercion (SymCo Coercion
co) = HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co

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

lintCoercion the_co :: Coercion
the_co@(SelCo CoSel
cs Coercion
co)
  = do { HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co
       ; Pair s t <- Coercion -> LintM (Pair InType)
substCoKindM Coercion
co

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

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

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

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

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


lintCoercion orig_co :: Coercion
orig_co@(InstCo Coercion
co Coercion
arg)
  = Coercion -> [Coercion] -> LintM ()
go Coercion
co [Coercion
arg]
  where
    go :: Coercion -> [Coercion] -> LintM ()
go (InstCo Coercion
co Coercion
arg) [Coercion]
args = do { HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
arg; Coercion -> [Coercion] -> LintM ()
go Coercion
co (Coercion
argCoercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
:[Coercion]
args) }
    go Coercion
co              [Coercion]
args = do { HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co
                                 ; let Pair InType
lty InType
rty = HasDebugCallStack => Coercion -> Pair InType
Coercion -> Pair InType
coercionKind Coercion
co
                                 ; lty' <- InType -> LintM InType
substTyM InType
lty
                                 ; rty' <- substTyM rty
                                 ; in_scope <- getInScope
                                 ; let subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
                                 ; go_args (subst, lty') (subst,rty') args }

    -------------
    go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion]
           -> LintM ()
    go_args :: (Subst, InType) -> (Subst, InType) -> [Coercion] -> LintM ()
go_args (Subst, InType)
_ (Subst, InType)
_ []
      = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go_args (Subst, InType)
lty (Subst, InType)
rty (Coercion
arg:[Coercion]
args)
      = do { (lty1, rty1)  <- (Subst, InType)
-> (Subst, InType)
-> Coercion
-> LintM ((Subst, InType), (Subst, InType))
go_arg (Subst, InType)
lty (Subst, InType)
rty Coercion
arg
           ; go_args lty1 rty1 args }

    -------------
    go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion
           -> LintM ((Subst,OutType), (Subst,OutType))
    go_arg :: (Subst, InType)
-> (Subst, InType)
-> Coercion
-> LintM ((Subst, InType), (Subst, InType))
go_arg (Subst
lsubst,InType
lty) (Subst
rsubst,InType
rty) Coercion
arg
      = do { Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
arg Role
Nominal (Coercion -> Role
coercionRole Coercion
arg)
           ; Pair arg_lty arg_rty <- Coercion -> LintM (Pair InType)
substCoKindM Coercion
arg

           ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of
              -- forall over tvar
                (Just (Var
ltv,InType
lty1), Just (Var
rtv,InType
rty1))
                  | HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
arg_lty HasCallStack => InType -> InType -> Bool
InType -> InType -> Bool
`eqType` HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy Subst
lsubst (Var -> InType
tyVarKind Var
ltv)
                  , HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
arg_rty HasCallStack => InType -> InType -> Bool
InType -> InType -> Bool
`eqType` HasDebugCallStack => Subst -> InType -> InType
Subst -> InType -> InType
substTy Subst
rsubst (Var -> InType
tyVarKind Var
rtv)
                  -> ((Subst, InType), (Subst, InType))
-> LintM ((Subst, InType), (Subst, InType))
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( (Subst -> Var -> InType -> Subst
extendTCvSubst Subst
lsubst Var
ltv InType
arg_lty, InType
lty1)
                            , (Subst -> Var -> InType -> Subst
extendTCvSubst Subst
rsubst Var
rtv InType
arg_rty, InType
rty1) )
                  | Bool
otherwise
                  -> SDoc -> LintM ((Subst, InType), (Subst, InType))
forall a. SDoc -> LintM a
failWithL (SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Kind mis-match in inst coercion")
                                   JoinArity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
arg
                                           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lty"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
lty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
lty)
                                           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rty"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
rty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
rty)
                                           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg_lty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
arg_lty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
arg_lty)
                                           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg_rty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
arg_rty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => InType -> InType
InType -> InType
typeKind InType
arg_rty)
                                           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ltv" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
ltv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> InType
tyVarKind Var
ltv)
                                           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rtv" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
rtv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> InType
tyVarKind Var
rtv) ]))

                (Maybe (Var, InType), Maybe (Var, InType))
_ -> SDoc -> LintM ((Subst, InType), (Subst, InType))
forall a. SDoc -> LintM a
failWithL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Bad argument of inst" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
orig_co) }

lintCoercion this_co :: Coercion
this_co@(AxiomCo CoAxiomRule
ax [Coercion]
cos)
  = do { (Coercion -> LintM ()) -> [Coercion] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion [Coercion]
cos
       ; JoinArity -> [Role] -> [Coercion] -> LintM ()
lint_roles JoinArity
0 (CoAxiomRule -> [Role]
coAxiomRuleArgRoles CoAxiomRule
ax) [Coercion]
cos
       ; prs <- (Coercion -> LintM (Pair InType))
-> [Coercion] -> LintM [Pair InType]
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 (Pair InType)
substCoKindM [Coercion]
cos
       ; lint_ax ax prs }

  where
    lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM ()
    lint_ax :: CoAxiomRule -> [Pair InType] -> LintM ()
lint_ax (BuiltInFamRew  BuiltInFamRewrite
bif) [Pair InType]
prs
      = Bool -> SDoc -> LintM ()
checkL (Maybe (Pair InType) -> Bool
forall a. Maybe a -> Bool
isJust (BuiltInFamRewrite -> [Pair InType] -> Maybe (Pair InType)
bifrw_proves BuiltInFamRewrite
bif [Pair InType]
prs))  SDoc
bad_bif
    lint_ax (BuiltInFamInj BuiltInFamInjectivity
bif) [Pair InType]
prs
      = Bool -> SDoc -> LintM ()
checkL (case [Pair InType]
prs of
                  [Pair InType
pr] -> Maybe (Pair InType) -> Bool
forall a. Maybe a -> Bool
isJust (BuiltInFamInjectivity -> Pair InType -> Maybe (Pair InType)
bifinj_proves BuiltInFamInjectivity
bif Pair InType
pr)
                  [Pair InType]
_    -> Bool
False)
               SDoc
bad_bif
    lint_ax (UnbranchedAxiom CoAxiom Unbranched
ax) [Pair InType]
prs
      = Coercion -> TyCon -> CoAxBranch -> [Pair InType] -> LintM ()
lintBranch Coercion
this_co (CoAxiom Unbranched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Unbranched
ax) (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
ax) [Pair InType]
prs
    lint_ax (BranchedAxiom CoAxiom Branched
ax JoinArity
ind) [Pair InType]
prs
      = do { Bool -> SDoc -> LintM ()
checkL (JoinArity
0 JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
<= JoinArity
ind Bool -> Bool -> Bool
&& JoinArity
ind JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
< Branches Branched -> JoinArity
forall (br :: BranchFlag). Branches br -> JoinArity
numBranches (CoAxiom Branched -> Branches Branched
forall (br :: BranchFlag). CoAxiom br -> Branches br
coAxiomBranches CoAxiom Branched
ax))
                    (Coercion -> SDoc -> SDoc
bad_ax Coercion
this_co (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"index out of range"))
           ; Coercion -> TyCon -> CoAxBranch -> [Pair InType] -> LintM ()
lintBranch Coercion
this_co (CoAxiom Branched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Branched
ax) (CoAxiom Branched -> JoinArity -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> JoinArity -> CoAxBranch
coAxiomNthBranch CoAxiom Branched
ax JoinArity
ind) [Pair InType]
prs }

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

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

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

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

lintCoercion (KindCo Coercion
co) = HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co

lintCoercion (SubCo Coercion
co)
  = do { HasDebugCallStack => Coercion -> LintM ()
Coercion -> LintM ()
lintCoercion Coercion
co
       ; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co Role
Nominal (Coercion -> Role
coercionRole Coercion
co) }

lintCoercion (HoleCo CoercionHole
h)
  = SDoc -> LintM ()
forall a. SDoc -> LintM a
failWithL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unfilled coercion hole:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoercionHole -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionHole
h)

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

       , LintEnv -> Subst
le_subst :: Subst
                  -- Current substitution, for TyCoVars only.
                  -- Non-CoVar Ids don't appear in here, not even in the InScopeSet
                  -- Used for (a) cloning to avoid shadowing of TyCoVars,
                  --              so that eqType works ok
                  --          (b) substituting for let-bound tyvars, when we have
                  --              (let @a = Int -> Int in ...)

       , LintEnv -> VarEnv (Var, InType)
le_in_vars :: VarEnv (InVar, OutType)
                    -- Maps an InVar (i.e. its unique) to its binding InVar
                    --    and to its OutType
                    -- /All/ in-scope variables are here (term variables,
                    --    type variables, and coercion variables)
                    -- Used at an occurrence of the InVar

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

       , LintEnv -> NameEnv UsageEnv
le_ue_aliases :: NameEnv UsageEnv
             -- See Note [Linting linearity]
             -- Assigns usage environments to the alias-like binders,
             -- as found in non-recursive lets.
             -- Domain is OutIds

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

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

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

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


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

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

type WarnsAndErrs = (Bag SDoc, Bag SDoc)

-- Using a unboxed tuple here reduced allocations for a lint heavy
-- file by ~6%. Using MaybeUB reduced them further by another ~12%.
--
-- Warning: if you don't inline the matcher for JustUB etc, Lint becomes
-- /tremendously/ inefficient, and compiling GHC.Tc.Errors.Types (which
-- contains gigantic types) is very very slow indeed. Conclusion: make
-- sure unfoldings are expose in GHC.Data.Unboxed, and that you compile
-- Lint.hs with optimistation on.
type LResult a = (# MaybeUB a, WarnsAndErrs #)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

* When do we /check linearity/ in Lint?  That is, when is `-dlinear-core-lint`
  lint set?  Answer: we check linearity in the output of the desugarer, shortly
  after type checking.

* When so we /not/ check linearity in Lint?  On all passes after desugaring.  Why?
  Because optimisation passes are not (yet) guaranteed to maintain linearity.
  They should do so semantically (GHC is careful not to duplicate computation)
  but it is much harder to ensure that the statically-checkable constraints of
  Linear Core are maintained. See examples below.

The current Linear Core is described in the wiki at:
https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.

Concretely, "ignore linearity in Lint" specifically means two things:
* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`
* In `ensureSubMult`, do nothing

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

* EXAMPLE 1: the binder swap transformation
    Consider

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

    The wrapper for MkT is

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

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

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

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

    Binder-swap changes this to

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

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

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

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

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

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

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

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

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

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

     f :: A %1 -> B

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

   Eta-reduction undoes this and produces:

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

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

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

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

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

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

There are two situations:

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

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

For 1, consider for example 'coerce':

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

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

  coerce @{rep1} ...

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

For 2, whenever we have an unlifted newtype such as

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

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

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

and an unsaturated occurrence

  MkN @ty -- NB: no value argument!

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

instance Applicative LintM where
      pure :: forall a. a -> LintM a
pure a
x = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
_ WarnsAndErrs
errs -> MaybeUB a -> WarnsAndErrs -> LResult a
forall a. MaybeUB a -> WarnsAndErrs -> LResult a
LResult (a -> MaybeUB a
forall a. a -> MaybeUB a
JustUB a
x) WarnsAndErrs
errs
                                   --(Just x, errs)
      <*> :: forall a b. LintM (a -> b) -> LintM a -> LintM b
(<*>) = LintM (a -> b) -> LintM a -> LintM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   cxt_doc :: SDoc
cxt_doc = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((SrcLoc, SDoc) -> SDoc) -> [(SrcLoc, SDoc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SrcLoc, SDoc) -> SDoc
forall a b. (a, b) -> b
snd [(SrcLoc, SDoc)]
loc_msgs
                  , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Substitution:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LintEnv -> Subst
le_subst LintEnv
env) ]

   context :: SDoc
context | Bool
show_context  = SDoc
cxt_doc
           | Bool
otherwise     = SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug SDoc
cxt_doc
     -- Print voluminous info for Lint errors
     -- but not for warnings

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

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

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

addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a
-- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned
addInScopeId :: forall a. Var -> InType -> (Var -> LintM a) -> LintM a
addInScopeId Var
in_id InType
out_ty Var -> LintM a
thing_inside
  = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs ->
    let !(Var
out_id, LintEnv
env') = LintEnv -> (Var, LintEnv)
add LintEnv
env
    in LintM a -> LintEnv -> WarnsAndErrs -> LResult a
forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
unLintM (Var -> LintM a
thing_inside Var
out_id) LintEnv
env' WarnsAndErrs
errs

  where
    add :: LintEnv -> (Var, LintEnv)
add env :: LintEnv
env@(LE { le_in_vars :: LintEnv -> VarEnv (Var, InType)
le_in_vars = VarEnv (Var, InType)
id_vars, le_joins :: LintEnv -> IdSet
le_joins = IdSet
join_set
                , le_ue_aliases :: LintEnv -> NameEnv UsageEnv
le_ue_aliases = NameEnv UsageEnv
aliases, le_subst :: LintEnv -> Subst
le_subst = Subst
subst })
      = (Var
out_id, LintEnv
env1)
      where
        env1 :: LintEnv
env1 = LintEnv
env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }

        in_vars' :: VarEnv (Var, InType)
in_vars' = VarEnv (Var, InType)
-> Var -> (Var, InType) -> VarEnv (Var, InType)
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv VarEnv (Var, InType)
id_vars Var
in_id (Var
in_id, InType
out_ty)
        aliases' :: NameEnv UsageEnv
aliases' = NameEnv UsageEnv -> Name -> NameEnv UsageEnv
forall a. NameEnv a -> Name -> NameEnv a
delFromNameEnv NameEnv UsageEnv
aliases (Var -> Name
idName Var
in_id)
           -- aliases': when shadowing an alias, we need to make sure the
           -- Id is no longer classified as such. E.g.
           --   let x = <e1> in case x of x { _DEFAULT -> <e2> }
           -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.

        -- A very tiny optimisation, not sure if it's really worth it
        -- Short-cut when the substitution is a no-op
        out_id :: Var
out_id | Subst -> Bool
isEmptyTCvSubst Subst
subst = Var
in_id
               | Bool
otherwise             = Var -> InType -> Var
setIdType Var
in_id InType
out_ty

        join_set' :: IdSet
join_set'
          | Var -> Bool
isJoinId Var
out_id = IdSet -> Var -> IdSet
extendVarSet IdSet
join_set Var
in_id -- Overwrite with new arity
          | Bool
otherwise       = IdSet -> Var -> IdSet
delVarSet    IdSet
join_set Var
in_id -- Remove any existing binding

addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a
-- This function clones to avoid shadowing of TyCoVars
addInScopeTyCoVar :: forall a. Var -> InType -> (Var -> LintM a) -> LintM a
addInScopeTyCoVar Var
tcv InType
tcv_type Var -> LintM a
thing_inside
  = (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> LResult a) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ env :: LintEnv
env@(LE { le_in_vars :: LintEnv -> VarEnv (Var, InType)
le_in_vars = VarEnv (Var, InType)
in_vars, le_subst :: LintEnv -> Subst
le_subst = Subst
subst }) WarnsAndErrs
errs ->
    let (Var
tcv', Subst
subst') = Subst -> (Var, Subst)
subst_bndr Subst
subst
        env' :: LintEnv
env' = LintEnv
env { le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type)
                   , le_subst = subst' }
    in LintM a -> LintEnv -> WarnsAndErrs -> LResult a
forall a. LintM a -> LintEnv -> WarnsAndErrs -> LResult a
unLintM (Var -> LintM a
thing_inside Var
tcv') LintEnv
env' WarnsAndErrs
errs
  where
    subst_bndr :: Subst -> (Var, Subst)
subst_bndr Subst
subst
      | Subst -> Bool
isEmptyTCvSubst Subst
subst                -- No change in kind
      , Bool -> Bool
not (Var
tcv Var -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
in_scope)  -- Not already in scope
      = -- Do not extend the substitution, just the in-scope set
        (if (Var -> InType
varType Var
tcv HasCallStack => InType -> InType -> Bool
InType -> InType -> Bool
`eqType` InType
tcv_type) then (\(Var, Subst)
x->(Var, Subst)
x) else
          String -> SDoc -> (Var, Subst) -> (Var, Subst)
forall a. String -> SDoc -> a -> a
pprTrace String
"addInScopeTyCoVar" (
            [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tcv" 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. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> InType
varType Var
tcv)
                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tcv_type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
tcv_type ])) ((Var, Subst) -> (Var, Subst)) -> (Var, Subst) -> (Var, Subst)
forall a b. (a -> b) -> a -> b
$
        (Var
tcv, Subst
subst Subst -> Var -> Subst
`extendSubstInScope` Var
tcv)

      -- Clone, and extend the substitution
      | let tcv' :: Var
tcv' = InScopeSet -> Var -> Var
uniqAway InScopeSet
in_scope (Var -> InType -> Var
setVarType Var
tcv InType
tcv_type)
      = (Var
tcv', Subst -> Var -> Var -> Subst
extendTCvSubstWithClone Subst
subst Var
tcv Var
tcv')
      where
        in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
substInScopeSet Subst
subst

getInVarEnv :: LintM (VarEnv (InId, OutType))
getInVarEnv :: LintM (VarEnv (Var, InType))
getInVarEnv = (LintEnv -> WarnsAndErrs -> LResult (VarEnv (Var, InType)))
-> LintM (VarEnv (Var, InType))
forall a. (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
LintM (\LintEnv
env WarnsAndErrs
errs -> (Maybe (VarEnv (Var, InType)), WarnsAndErrs)
-> LResult (VarEnv (Var, InType))
forall a. (Maybe a, WarnsAndErrs) -> LResult a
fromBoxedLResult (VarEnv (Var, InType) -> Maybe (VarEnv (Var, InType))
forall a. a -> Maybe a
Just (LintEnv -> VarEnv (Var, InType)
le_in_vars LintEnv
env), WarnsAndErrs
errs))

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

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

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

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

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

substTyM :: InType -> LintM OutType
-- Apply the substitution to the type
-- The substitution is often empty, in which case it is a no-op
substTyM :: InType -> LintM InType
substTyM InType
ty
  = do { subst <- LintM Subst
getSubst
       ; return (substTy subst ty) }

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

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

lintVarOcc :: InVar -> LintM OutType
-- Used at an occurrence of a variable: term variables, type variables, and coercion variables
-- Checks two things:
-- a) that it is in scope
-- b) that the InType at the ocurrences matches the InType at the binding site
lintVarOcc :: Var -> LintM InType
lintVarOcc Var
v_occ
  = do { in_var_env <- LintM (VarEnv (Var, InType))
getInVarEnv
       ; case lookupVarEnv in_var_env v_occ of
           Maybe (Var, InType)
Nothing | Var -> Bool
isGlobalId Var
v_occ -> InType -> LintM InType
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> InType
idType Var
v_occ)
                   | Bool
otherwise        -> SDoc -> LintM InType
forall a. SDoc -> LintM a
failWithL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
pp_what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v_occ)
                                                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is out of scope")
           Just (Var
v_bndr, InType
out_ty) -> do { Var -> LintM ()
check_bad_global Var
v_bndr
                                       ; InType -> InType -> SDoc -> LintM ()
ensureEqTys InType
occ_ty InType
bndr_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$  -- Compares InTypes
                                         Var -> InType -> InType -> SDoc
mkBndrOccTypeMismatchMsg Var
v_occ InType
bndr_ty InType
occ_ty
                                       ; InType -> LintM InType
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return InType
out_ty }
             where
               occ_ty :: InType
occ_ty  = Var -> InType
varType Var
v_occ
               bndr_ty :: InType
bndr_ty = Var -> InType
varType Var
v_bndr }
  where
    pp_what :: String
pp_what | Var -> Bool
isTyVar Var
v_occ = String
"The type variable"
            | Var -> Bool
isCoVar Var
v_occ = String
"The coercion variable"
            | Bool
otherwise     = String
"The value variable"

       -- 'check_bad_global' checks for the case where an /occurrence/ is
       -- a GlobalId, but there is an enclosing binding fora a LocalId.
       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,
       --     but GHCi adds GlobalIds from the interactive context.  These
       --     are fine; hence the test (isLocalId id == isLocalId v)
       -- NB: when compiling Control.Exception.Base, things like absentError
       --     are defined locally, but appear in expressions as (global)
       --     wired-in Ids after worker/wrapper
       --     So we simply disable the test in this case
    check_bad_global :: Var -> LintM ()
check_bad_global Var
v_bndr
      | Var -> Bool
isGlobalId Var
v_occ
      , Var -> Bool
isLocalId Var
v_bndr
      , Bool -> Bool
not (Var -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn Var
v_occ)
      = 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
"Occurrence is GlobalId, but binding is LocalId")
                       JoinArity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"occurrence:") JoinArity
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
v_occ
                               , SDoc -> JoinArity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"binder    :") JoinArity
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
v_bndr ])
      | Bool
otherwise
      = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

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

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

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

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

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

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

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

dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

pp_binders :: [Var] -> SDoc
pp_binders :: [Var] -> SDoc
pp_binders [Var]
bs = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> SDoc
pp_binder [Var]
bs))

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc
mkBndrOccTypeMismatchMsg :: Var -> InType -> InType -> SDoc
mkBndrOccTypeMismatchMsg Var
var InType
bndr_ty InType
occ_ty
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Mismatch in type between binder and occurrence"
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Binder:    " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
bndr_ty
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Occurrence:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InType -> SDoc
forall a. Outputable a => a -> SDoc
ppr InType
occ_ty ]

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

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

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

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

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

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