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

A lint pass to check basic STG invariants:

- Variables should be defined before used.

- Let bindings should not have unboxed types (unboxed bindings should only
  appear in case), except when they're join points (see Note [CoreSyn let/app
  invariant] and #14117).

- If linting after unarisation, invariants listed in Note [Post-unarisation
  invariants].

Because we don't have types and coercions in STG we can't really check types
here.

Some history:

StgLint used to check types, but it never worked and so it was disabled in 2000
with this note:

    WARNING:
    ~~~~~~~~

    This module has suffered bit-rot; it is likely to yield lint errors
    for Stg code that is currently perfectly acceptable for code
    generation.  Solution: don't use it!  (KSW 2000-05).

Since then there were some attempts at enabling it again, as summarised in
#14787. It's finally decided that we remove all type checking and only look for
basic properties listed above.
-}

{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
  DeriveFunctor #-}

module StgLint ( lintStgTopBindings ) where

import GhcPrelude

import StgSyn

import DynFlags
import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import BasicTypes       ( TopLevelFlag(..), isTopLevel )
import CostCentre       ( isCurrentCCS )
import Id               ( Id, idType, isJoinId, idName )
import VarSet
import DataCon
import CoreSyn          ( AltCon(..) )
import Name             ( getSrcLoc, nameIsLocalOrFrom )
import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
import Type
import RepType
import SrcLoc
import Outputable
import Module           ( Module )
import qualified ErrUtils as Err
import Control.Applicative ((<|>))
import Control.Monad

lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                   => DynFlags
                   -> Module -- ^ module being compiled
                   -> Bool   -- ^ have we run Unarise yet?
                   -> String -- ^ who produced the STG?
                   -> [GenStgTopBinding a]
                   -> IO ()

lintStgTopBindings :: DynFlags
-> Module -> Bool -> String -> [GenStgTopBinding a] -> IO ()
lintStgTopBindings DynFlags
dflags Module
this_mod Bool
unarised String
whodunnit [GenStgTopBinding a]
binds
  = {-# SCC "StgLint" #-}
    case Module -> Bool -> IdSet -> LintM () -> Maybe MsgDoc
forall a. Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
initL Module
this_mod Bool
unarised IdSet
top_level_binds ([GenStgTopBinding a] -> LintM ()
lint_binds [GenStgTopBinding a]
binds) of
      Maybe MsgDoc
Nothing  ->
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just MsgDoc
msg -> do
        DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
Err.SevDump SrcSpan
noSrcSpan
          (DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags)
          ([MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"*** Stg Lint ErrMsgs: in" MsgDoc -> MsgDoc -> MsgDoc
<+>
                        String -> MsgDoc
text String
whodunnit MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"***",
                  MsgDoc
msg,
                  String -> MsgDoc
text String
"*** Offending Program ***",
                  [GenStgTopBinding a] -> MsgDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgTopBinding pass] -> MsgDoc
pprGenStgTopBindings [GenStgTopBinding a]
binds,
                  String -> MsgDoc
text String
"*** End of Offense ***"])
        DynFlags -> Int -> IO ()
Err.ghcExit DynFlags
dflags Int
1
  where
    -- Bring all top-level binds into scope because CoreToStg does not generate
    -- bindings in dependency order (so we may see a use before its definition).
    top_level_binds :: IdSet
top_level_binds = [Var] -> IdSet
mkVarSet ([GenStgTopBinding a] -> [Var]
forall (a :: StgPass).
(BinderP a ~ Var) =>
[GenStgTopBinding a] -> [Var]
bindersOfTopBinds [GenStgTopBinding a]
binds)

    lint_binds :: [GenStgTopBinding a] -> LintM ()

    lint_binds :: [GenStgTopBinding a] -> LintM ()
lint_binds [] = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    lint_binds (GenStgTopBinding a
bind:[GenStgTopBinding a]
binds) = do
        [Var]
binders <- GenStgTopBinding a -> LintM [Var]
forall (a :: StgPass).
(Outputable (XLet a), Outputable (XLetNoEscape a),
 Outputable (XRhsClosure a), OutputableBndr (BinderP a),
 BinderP a ~ Var) =>
GenStgTopBinding a -> LintM [Var]
lint_bind GenStgTopBinding a
bind
        [Var] -> LintM () -> LintM ()
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
            [GenStgTopBinding a] -> LintM ()
lint_binds [GenStgTopBinding a]
binds

    lint_bind :: GenStgTopBinding a -> LintM [Var]
lint_bind (StgTopLifted GenStgBinding a
bind) = TopLevelFlag -> GenStgBinding a -> LintM [Var]
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
TopLevelFlag -> GenStgBinding a -> LintM [Var]
lintStgBinds TopLevelFlag
TopLevel GenStgBinding a
bind
    lint_bind (StgTopStringLit Var
v ByteString
_) = [Var] -> LintM [Var]
forall (m :: * -> *) a. Monad m => a -> m a
return [Var
v]

lintStgArg :: StgArg -> LintM ()
lintStgArg :: StgArg -> LintM ()
lintStgArg (StgLitArg Literal
_) = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintStgArg (StgVarArg Var
v) = Var -> LintM ()
lintStgVar Var
v

lintStgVar :: Id -> LintM ()
lintStgVar :: Var -> LintM ()
lintStgVar Var
id = Var -> LintM ()
checkInScope Var
id

lintStgBinds
    :: (OutputablePass a, BinderP a ~ Id)
    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
lintStgBinds :: TopLevelFlag -> GenStgBinding a -> LintM [Var]
lintStgBinds TopLevelFlag
top_lvl (StgNonRec BinderP a
binder GenStgRhs a
rhs) = do
    TopLevelFlag -> (Var, GenStgRhs a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
TopLevelFlag -> (Var, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (Var
BinderP a
binder,GenStgRhs a
rhs)
    [Var] -> LintM [Var]
forall (m :: * -> *) a. Monad m => a -> m a
return [Var
BinderP a
binder]

lintStgBinds TopLevelFlag
top_lvl (StgRec [(BinderP a, GenStgRhs a)]
pairs)
  = [Var] -> LintM [Var] -> LintM [Var]
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var]
binders (LintM [Var] -> LintM [Var]) -> LintM [Var] -> LintM [Var]
forall a b. (a -> b) -> a -> b
$ do
        ((Var, GenStgRhs a) -> LintM ())
-> [(Var, GenStgRhs a)] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TopLevelFlag -> (Var, GenStgRhs a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
TopLevelFlag -> (Var, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl) [(Var, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs
        [Var] -> LintM [Var]
forall (m :: * -> *) a. Monad m => a -> m a
return [Var]
binders
  where
    binders :: [Var]
binders = [Var
b | (Var
b,GenStgRhs a
_) <- [(Var, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs]

lint_binds_help
    :: (OutputablePass a, BinderP a ~ Id)
    => TopLevelFlag
    -> (Id, GenStgRhs a)
    -> LintM ()
lint_binds_help :: TopLevelFlag -> (Var, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (Var
binder, GenStgRhs a
rhs)
  = LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RhsOf Var
binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) (GenStgRhs a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgRhs a -> LintM ()
checkNoCurrentCCS GenStgRhs a
rhs)
        GenStgRhs a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgRhs a -> LintM ()
lintStgRhs GenStgRhs a
rhs
        -- Check binder doesn't have unlifted type or it's a join point
        Bool -> MsgDoc -> LintM ()
checkL (Var -> Bool
isJoinId Var
binder Bool -> Bool -> Bool
|| Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Var -> Type
idType Var
binder)))
               (Var -> GenStgRhs a -> MsgDoc
forall (a :: StgPass).
OutputablePass a =>
Var -> GenStgRhs a -> MsgDoc
mkUnliftedTyMsg Var
binder GenStgRhs a
rhs)

-- | Top-level bindings can't inherit the cost centre stack from their
-- (static) allocation site.
checkNoCurrentCCS
    :: (OutputablePass a, BinderP a ~ Id)
    => GenStgRhs a
    -> LintM ()
checkNoCurrentCCS :: GenStgRhs a -> LintM ()
checkNoCurrentCCS rhs :: GenStgRhs a
rhs@(StgRhsClosure XRhsClosure a
_ CostCentreStack
ccs UpdateFlag
_ [BinderP a]
_ GenStgExpr a
_)
  | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
  = MsgDoc -> LintM ()
addErrL (String -> MsgDoc
text String
"Top-level StgRhsClosure with CurrentCCS" MsgDoc -> MsgDoc -> MsgDoc
$$ GenStgRhs a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenStgRhs a
rhs)
checkNoCurrentCCS rhs :: GenStgRhs a
rhs@(StgRhsCon CostCentreStack
ccs DataCon
_ [StgArg]
_)
  | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
  = MsgDoc -> LintM ()
addErrL (String -> MsgDoc
text String
"Top-level StgRhsCon with CurrentCCS" MsgDoc -> MsgDoc -> MsgDoc
$$ GenStgRhs a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenStgRhs a
rhs)
checkNoCurrentCCS GenStgRhs a
_
  = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()

lintStgRhs :: GenStgRhs a -> LintM ()
lintStgRhs (StgRhsClosure XRhsClosure a
_ CostCentreStack
_ UpdateFlag
_ [] GenStgExpr a
expr)
  = GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr

lintStgRhs (StgRhsClosure XRhsClosure a
_ CostCentreStack
_ UpdateFlag
_ [BinderP a]
binders GenStgExpr a
expr)
  = LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
LambdaBodyOf [Var]
[BinderP a]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      [Var] -> LintM () -> LintM ()
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var]
[BinderP a]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
        GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr

lintStgRhs rhs :: GenStgRhs a
rhs@(StgRhsCon CostCentreStack
_ DataCon
con [StgArg]
args) = do
    Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataCon -> Bool
isUnboxedTupleCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumCon DataCon
con) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      MsgDoc -> LintM ()
addErrL (String -> MsgDoc
text String
"StgRhsCon is an unboxed tuple or sum application" MsgDoc -> MsgDoc -> MsgDoc
$$
               GenStgRhs a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenStgRhs a
rhs)
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
checkPostUnariseConArg [StgArg]
args

lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()

lintStgExpr :: GenStgExpr a -> LintM ()
lintStgExpr (StgLit Literal
_) = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

lintStgExpr (StgApp Var
fun [StgArg]
args) = do
    Var -> LintM ()
lintStgVar Var
fun
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args

lintStgExpr app :: GenStgExpr a
app@(StgConApp DataCon
con [StgArg]
args [Type]
_arg_tys) = do
    -- unboxed sums should vanish during unarise
    LintFlags
lf <- LintM LintFlags
getLintFlags
    Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf Bool -> Bool -> Bool
&& DataCon -> Bool
isUnboxedSumCon DataCon
con) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      MsgDoc -> LintM ()
addErrL (String -> MsgDoc
text String
"Unboxed sum after unarise:" MsgDoc -> MsgDoc -> MsgDoc
$$
               GenStgExpr a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenStgExpr a
app)
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
checkPostUnariseConArg [StgArg]
args

lintStgExpr (StgOpApp StgOp
_ [StgArg]
args Type
_) =
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args

lintStgExpr lam :: GenStgExpr a
lam@(StgLam NonEmpty (BinderP a)
_ StgExpr
_) =
    MsgDoc -> LintM ()
addErrL (String -> MsgDoc
text String
"Unexpected StgLam" MsgDoc -> MsgDoc -> MsgDoc
<+> GenStgExpr a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenStgExpr a
lam)

lintStgExpr (StgLet XLet a
_ GenStgBinding a
binds GenStgExpr a
body) = do
    [Var]
binders <- TopLevelFlag -> GenStgBinding a -> LintM [Var]
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
TopLevelFlag -> GenStgBinding a -> LintM [Var]
lintStgBinds TopLevelFlag
NotTopLevel GenStgBinding a
binds
    LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      [Var] -> LintM () -> LintM ()
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
        GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
body

lintStgExpr (StgLetNoEscape XLetNoEscape a
_ GenStgBinding a
binds GenStgExpr a
body) = do
    [Var]
binders <- TopLevelFlag -> GenStgBinding a -> LintM [Var]
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
TopLevelFlag -> GenStgBinding a -> LintM [Var]
lintStgBinds TopLevelFlag
NotTopLevel GenStgBinding a
binds
    LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      [Var] -> LintM () -> LintM ()
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
        GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
body

lintStgExpr (StgTick Tickish Var
_ GenStgExpr a
expr) = GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr

lintStgExpr (StgCase GenStgExpr a
scrut BinderP a
bndr AltType
alts_type [GenStgAlt a]
alts) = do
    GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
scrut

    LintFlags
lf <- LintM LintFlags
getLintFlags
    let in_scope :: Bool
in_scope = AltType -> Bool -> Bool
stgCaseBndrInScope AltType
alts_type (LintFlags -> Bool
lf_unarised LintFlags
lf)

    [Var] -> LintM () -> LintM ()
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var
BinderP a
bndr | Bool
in_scope] (((AltCon, [Var], GenStgExpr a) -> LintM ())
-> [(AltCon, [Var], GenStgExpr a)] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AltCon, [Var], GenStgExpr a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
(AltCon, [Var], GenStgExpr a) -> LintM ()
lintAlt [(AltCon, [Var], GenStgExpr a)]
[GenStgAlt a]
alts)

lintAlt
    :: (OutputablePass a, BinderP a ~ Id)
    => (AltCon, [Id], GenStgExpr a) -> LintM ()

lintAlt :: (AltCon, [Var], GenStgExpr a) -> LintM ()
lintAlt (AltCon
DEFAULT, [Var]
_, GenStgExpr a
rhs) =
    GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs

lintAlt (LitAlt Literal
_, [Var]
_, GenStgExpr a
rhs) =
    GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs

lintAlt (DataAlt DataCon
_, [Var]
bndrs, GenStgExpr a
rhs) = do
    (Var -> LintM ()) -> [Var] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Var -> LintM ()
checkPostUnariseBndr [Var]
bndrs
    [Var] -> LintM () -> LintM ()
forall a. [Var] -> LintM a -> LintM a
addInScopeVars [Var]
bndrs (GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Var) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs)

{-
************************************************************************
*                                                                      *
Utilities
*                                                                      *
************************************************************************
-}

bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
bindersOf :: GenStgBinding a -> [Var]
bindersOf (StgNonRec BinderP a
binder GenStgRhs a
_) = [Var
BinderP a
binder]
bindersOf (StgRec [(BinderP a, GenStgRhs a)]
pairs)       = [Var
binder | (Var
binder, GenStgRhs a
_) <- [(Var, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs]

bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
bindersOfTop :: GenStgTopBinding a -> [Var]
bindersOfTop (StgTopLifted GenStgBinding a
bind) = GenStgBinding a -> [Var]
forall (a :: StgPass).
(BinderP a ~ Var) =>
GenStgBinding a -> [Var]
bindersOf GenStgBinding a
bind
bindersOfTop (StgTopStringLit Var
binder ByteString
_) = [Var
binder]

bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
bindersOfTopBinds :: [GenStgTopBinding a] -> [Var]
bindersOfTopBinds = (GenStgTopBinding a -> [Var] -> [Var])
-> [Var] -> [GenStgTopBinding a] -> [Var]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
(++) ([Var] -> [Var] -> [Var])
-> (GenStgTopBinding a -> [Var])
-> GenStgTopBinding a
-> [Var]
-> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgTopBinding a -> [Var]
forall (a :: StgPass).
(BinderP a ~ Var) =>
GenStgTopBinding a -> [Var]
bindersOfTop) []

{-
************************************************************************
*                                                                      *
The Lint monad
*                                                                      *
************************************************************************
-}

newtype LintM a = LintM
    { LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM :: Module
              -> LintFlags
              -> [LintLocInfo]     -- Locations
              -> IdSet             -- Local vars in scope
              -> Bag MsgDoc        -- Error messages so far
              -> (a, Bag MsgDoc)   -- Result and error messages (if any)
    }
    deriving (a -> LintM b -> LintM a
(a -> b) -> LintM a -> LintM b
(forall a b. (a -> b) -> LintM a -> LintM b)
-> (forall a b. a -> LintM b -> LintM a) -> Functor LintM
forall a b. a -> LintM b -> LintM a
forall a b. (a -> b) -> LintM a -> LintM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LintM b -> LintM a
$c<$ :: forall a b. a -> LintM b -> LintM a
fmap :: (a -> b) -> LintM a -> LintM b
$cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
Functor)

data LintFlags = LintFlags { LintFlags -> Bool
lf_unarised :: !Bool
                             -- ^ have we run the unariser yet?
                           }

data LintLocInfo
  = RhsOf Id            -- The variable bound
  | LambdaBodyOf [Id]   -- The lambda-binder
  | BodyOfLetRec [Id]   -- One of the binders

dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc :: LintLocInfo -> (SrcSpan, MsgDoc)
dumpLoc (RhsOf Var
v) =
  (SrcLoc -> SrcSpan
srcLocSpan (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
v), String -> MsgDoc
text String
" [RHS of " MsgDoc -> MsgDoc -> MsgDoc
<> [Var] -> MsgDoc
pp_binders [Var
v] MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
']' )
dumpLoc (LambdaBodyOf [Var]
bs) =
  (SrcLoc -> SrcSpan
srcLocSpan (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc ([Var] -> Var
forall a. [a] -> a
head [Var]
bs)), String -> MsgDoc
text String
" [in body of lambda with binders " MsgDoc -> MsgDoc -> MsgDoc
<> [Var] -> MsgDoc
pp_binders [Var]
bs MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
']' )

dumpLoc (BodyOfLetRec [Var]
bs) =
  (SrcLoc -> SrcSpan
srcLocSpan (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc ([Var] -> Var
forall a. [a] -> a
head [Var]
bs)), String -> MsgDoc
text String
" [in body of letrec with binders " MsgDoc -> MsgDoc -> MsgDoc
<> [Var] -> MsgDoc
pp_binders [Var]
bs MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
']' )


pp_binders :: [Id] -> SDoc
pp_binders :: [Var] -> MsgDoc
pp_binders [Var]
bs
  = [MsgDoc] -> MsgDoc
sep (MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
comma ((Var -> MsgDoc) -> [Var] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> MsgDoc
pp_binder [Var]
bs))
  where
    pp_binder :: Var -> MsgDoc
pp_binder Var
b
      = [MsgDoc] -> MsgDoc
hsep [Var -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Var
b, MsgDoc
dcolon, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Var -> Type
idType Var
b)]

initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
initL Module
this_mod Bool
unarised IdSet
locals (LintM Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
m) = do
  let (a
_, Bag MsgDoc
errs) = Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
m Module
this_mod (Bool -> LintFlags
LintFlags Bool
unarised) [] IdSet
locals Bag MsgDoc
forall a. Bag a
emptyBag
  if Bag MsgDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag MsgDoc
errs then
      Maybe MsgDoc
forall a. Maybe a
Nothing
  else
      MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just ([MsgDoc] -> MsgDoc
vcat (MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
blankLine (Bag MsgDoc -> [MsgDoc]
forall a. Bag a -> [a]
bagToList Bag MsgDoc
errs)))

instance Applicative LintM where
      pure :: a -> LintM a
pure a
a = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> (a, Bag MsgDoc))
 -> LintM a)
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> (a, Bag MsgDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf [LintLocInfo]
_loc IdSet
_scope Bag MsgDoc
errs -> (a
a, Bag MsgDoc
errs)
      <*> :: LintM (a -> b) -> LintM a -> LintM b
(<*>) = LintM (a -> b) -> LintM a -> LintM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
      *> :: LintM a -> LintM b -> LintM b
(*>)  = LintM a -> LintM b -> LintM b
forall a b. LintM a -> LintM b -> LintM b
thenL_

instance Monad LintM where
    >>= :: LintM a -> (a -> LintM b) -> LintM b
(>>=) = LintM a -> (a -> LintM b) -> LintM b
forall a b. LintM a -> (a -> LintM b) -> LintM b
thenL
    >> :: LintM a -> LintM b -> LintM b
(>>)  = LintM a -> LintM b -> LintM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL LintM a
m a -> LintM b
k = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (b, Bag MsgDoc))
-> LintM b
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> (b, Bag MsgDoc))
 -> LintM b)
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> (b, Bag MsgDoc))
-> LintM b
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs
  -> case LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM LintM a
m Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs of
      (a
r, Bag MsgDoc
errs') -> LintM b
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (b, Bag MsgDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM (a -> LintM b
k a
r) Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs'

thenL_ :: LintM a -> LintM b -> LintM b
thenL_ :: LintM a -> LintM b -> LintM b
thenL_ LintM a
m LintM b
k = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (b, Bag MsgDoc))
-> LintM b
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> (b, Bag MsgDoc))
 -> LintM b)
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> (b, Bag MsgDoc))
-> LintM b
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs
  -> case LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM LintM a
m Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs of
      (a
_, Bag MsgDoc
errs') -> LintM b
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (b, Bag MsgDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM LintM b
k Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs'

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

-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr :: Var -> LintM ()
checkPostUnariseBndr Var
bndr = do
    LintFlags
lf <- LintM LintFlags
getLintFlags
    Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      Maybe String -> (String -> LintM ()) -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Var -> Maybe String
checkPostUnariseId Var
bndr) ((String -> LintM ()) -> LintM ())
-> (String -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \String
unexpected ->
        MsgDoc -> LintM ()
addErrL (MsgDoc -> LintM ()) -> MsgDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
          String -> MsgDoc
text String
"After unarisation, binder " MsgDoc -> MsgDoc -> MsgDoc
<>
          Var -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Var
bndr MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
" has " MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
unexpected MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
" type " MsgDoc -> MsgDoc -> MsgDoc
<>
          Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Var -> Type
idType Var
bndr)

-- Arguments shouldn't have sum, tuple, or void types.
checkPostUnariseConArg :: StgArg -> LintM ()
checkPostUnariseConArg :: StgArg -> LintM ()
checkPostUnariseConArg StgArg
arg = case StgArg
arg of
    StgLitArg Literal
_ ->
      () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    StgVarArg Var
id -> do
      LintFlags
lf <- LintM LintFlags
getLintFlags
      Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
        Maybe String -> (String -> LintM ()) -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Var -> Maybe String
checkPostUnariseId Var
id) ((String -> LintM ()) -> LintM ())
-> (String -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \String
unexpected ->
          MsgDoc -> LintM ()
addErrL (MsgDoc -> LintM ()) -> MsgDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
            String -> MsgDoc
text String
"After unarisation, arg " MsgDoc -> MsgDoc -> MsgDoc
<>
            Var -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Var
id MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
" has " MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
unexpected MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
" type " MsgDoc -> MsgDoc -> MsgDoc
<>
            Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Var -> Type
idType Var
id)

-- Post-unarisation args and case alt binders should not have unboxed tuple,
-- unboxed sum, or void types. Return what the binder is if it is one of these.
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId :: Var -> Maybe String
checkPostUnariseId Var
id =
    let
      id_ty :: Type
id_ty = Var -> Type
idType Var
id
      is_sum, is_tuple, is_void :: Maybe String
      is_sum :: Maybe String
is_sum = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
isUnboxedSumType Type
id_ty) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"unboxed sum"
      is_tuple :: Maybe String
is_tuple = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
isUnboxedTupleType Type
id_ty) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"unboxed tuple"
      is_void :: Maybe String
is_void = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
isVoidTy Type
id_ty) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"void"
    in
      Maybe String
is_sum Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
is_tuple Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
is_void

addErrL :: MsgDoc -> LintM ()
addErrL :: MsgDoc -> LintM ()
addErrL MsgDoc
msg = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> ((), Bag MsgDoc))
-> LintM ()
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> ((), Bag MsgDoc))
 -> LintM ())
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> ((), Bag MsgDoc))
-> LintM ()
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf [LintLocInfo]
loc IdSet
_scope Bag MsgDoc
errs -> ((), Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr Bag MsgDoc
errs MsgDoc
msg [LintLocInfo]
loc)

addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr Bag MsgDoc
errs_so_far MsgDoc
msg [LintLocInfo]
locs
  = Bag MsgDoc
errs_so_far Bag MsgDoc -> MsgDoc -> Bag MsgDoc
forall a. Bag a -> a -> Bag a
`snocBag` [LintLocInfo] -> MsgDoc
mk_msg [LintLocInfo]
locs
  where
    mk_msg :: [LintLocInfo] -> MsgDoc
mk_msg (LintLocInfo
loc:[LintLocInfo]
_) = let (SrcSpan
l,MsgDoc
hdr) = LintLocInfo -> (SrcSpan, MsgDoc)
dumpLoc LintLocInfo
loc
                     in  Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage Severity
SevWarning SrcSpan
l (MsgDoc
hdr MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
msg)
    mk_msg []      = MsgDoc
msg

addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
extra_loc LintM a
m = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> (a, Bag MsgDoc))
 -> LintM a)
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> (a, Bag MsgDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs
   -> LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM LintM a
m Module
mod LintFlags
lf (LintLocInfo
extra_locLintLocInfo -> [LintLocInfo] -> [LintLocInfo]
forall a. a -> [a] -> [a]
:[LintLocInfo]
loc) IdSet
scope Bag MsgDoc
errs

addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars [Var]
ids LintM a
m = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> (a, Bag MsgDoc))
 -> LintM a)
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> (a, Bag MsgDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs
 -> let
        new_set :: IdSet
new_set = [Var] -> IdSet
mkVarSet [Var]
ids
    in LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
unLintM LintM a
m Module
mod LintFlags
lf [LintLocInfo]
loc (IdSet
scope IdSet -> IdSet -> IdSet
`unionVarSet` IdSet
new_set) Bag MsgDoc
errs

getLintFlags :: LintM LintFlags
getLintFlags :: LintM LintFlags
getLintFlags = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (LintFlags, Bag MsgDoc))
-> LintM LintFlags
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> (LintFlags, Bag MsgDoc))
 -> LintM LintFlags)
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> (LintFlags, Bag MsgDoc))
-> LintM LintFlags
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
lf [LintLocInfo]
_loc IdSet
_scope Bag MsgDoc
errs -> (LintFlags
lf, Bag MsgDoc
errs)

checkInScope :: Id -> LintM ()
checkInScope :: Var -> LintM ()
checkInScope Var
id = (Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> ((), Bag MsgDoc))
-> LintM ()
forall a.
(Module
 -> LintFlags
 -> [LintLocInfo]
 -> IdSet
 -> Bag MsgDoc
 -> (a, Bag MsgDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> [LintLocInfo]
  -> IdSet
  -> Bag MsgDoc
  -> ((), Bag MsgDoc))
 -> LintM ())
-> (Module
    -> LintFlags
    -> [LintLocInfo]
    -> IdSet
    -> Bag MsgDoc
    -> ((), Bag MsgDoc))
-> LintM ()
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
_lf [LintLocInfo]
loc IdSet
scope Bag MsgDoc
errs
 -> if Module -> Name -> Bool
nameIsLocalOrFrom Module
mod (Var -> Name
idName Var
id) Bool -> Bool -> Bool
&& Bool -> Bool
not (Var
id Var -> IdSet -> Bool
`elemVarSet` IdSet
scope) then
        ((), Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr Bag MsgDoc
errs ([MsgDoc] -> MsgDoc
hsep [Var -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Var
id, MsgDoc
dcolon, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Var -> Type
idType Var
id),
                                String -> MsgDoc
text String
"is out of scope"]) [LintLocInfo]
loc)
    else
        ((), Bag MsgDoc
errs)

mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg :: Var -> GenStgRhs a -> MsgDoc
mkUnliftedTyMsg Var
binder GenStgRhs a
rhs
  = (String -> MsgDoc
text String
"Let(rec) binder" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Var -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Var
binder) MsgDoc -> MsgDoc -> MsgDoc
<+>
     String -> MsgDoc
text String
"has unlifted type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Var -> Type
idType Var
binder)))
    MsgDoc -> MsgDoc -> MsgDoc
$$
    (String -> MsgDoc
text String
"RHS:" MsgDoc -> MsgDoc -> MsgDoc
<+> GenStgRhs a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GenStgRhs a
rhs)