{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
DeriveFunctor #-}
module GHC.Stg.Lint ( lintStgTopBindings ) where
import GHC.Prelude
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Core.DataCon
import GHC.Core ( AltCon(..) )
import GHC.Core.Type
import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
import GHC.Types.CostCentre ( isCurrentCCS )
import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom )
import GHC.Types.RepType
import GHC.Types.SrcLoc
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Error ( mkLocMessage, DiagOpts )
import qualified GHC.Utils.Error as Err
import GHC.Unit.Module ( Module )
import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Control.Monad
import Data.Maybe
import GHC.Utils.Misc
import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
import GHC.Utils.Panic.Plain (panic)
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
=> Platform
-> Logger
-> DiagOpts
-> StgPprOpts
-> [Var]
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
Platform
-> Logger
-> DiagOpts
-> StgPprOpts
-> [Id]
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings Platform
platform Logger
logger DiagOpts
diag_opts StgPprOpts
opts [Id]
extra_vars Module
this_mod Bool
unarised String
whodunit [GenStgTopBinding a]
binds
= {-# SCC "StgLint" #-}
case Platform
-> DiagOpts
-> Module
-> Bool
-> StgPprOpts
-> IdSet
-> LintM ()
-> Maybe SDoc
forall a.
Platform
-> DiagOpts
-> Module
-> Bool
-> StgPprOpts
-> IdSet
-> LintM a
-> Maybe SDoc
initL Platform
platform DiagOpts
diag_opts Module
this_mod Bool
unarised StgPprOpts
opts IdSet
top_level_binds ([GenStgTopBinding a] -> LintM ()
lint_binds [GenStgTopBinding a]
binds) of
Maybe SDoc
Nothing ->
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just SDoc
msg -> do
Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
Err.MCDump SrcSpan
noSrcSpan
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"*** Stg Lint ErrMsgs: in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
whodunit SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"***",
SDoc
msg,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"*** Offending Program ***",
StgPprOpts -> [GenStgTopBinding a] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings StgPprOpts
opts [GenStgTopBinding a]
binds,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"*** End of Offense ***"])
Logger -> Int -> IO ()
Err.ghcExit Logger
logger Int
1
where
top_level_binds :: IdSet
top_level_binds = IdSet -> [Id] -> IdSet
extendVarSetList ([Id] -> IdSet
mkVarSet ([GenStgTopBinding a] -> [Id]
forall (a :: StgPass).
(BinderP a ~ Id) =>
[GenStgTopBinding a] -> [Id]
bindersOfTopBinds [GenStgTopBinding a]
binds))
[Id]
extra_vars
lint_binds :: [GenStgTopBinding a] -> LintM ()
lint_binds :: [GenStgTopBinding a] -> LintM ()
lint_binds [] = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lint_binds (GenStgTopBinding a
bind:[GenStgTopBinding a]
binds) = do
[Id]
binders <- GenStgTopBinding a -> LintM [Id]
forall {a :: StgPass}.
(BinderP a ~ Id, Outputable (XLet a), Outputable (XLetNoEscape a),
Outputable (XRhsClosure a)) =>
GenStgTopBinding a -> LintM [Id]
lint_bind GenStgTopBinding a
bind
[Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
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 [Id]
lint_bind (StgTopLifted GenStgBinding a
bind) = TopLevelFlag -> GenStgBinding a -> LintM [Id]
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
TopLevel GenStgBinding a
bind
lint_bind (StgTopStringLit Id
v ByteString
_) = [Id] -> LintM [Id]
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Id
v]
lintStgConArg :: StgArg -> LintM ()
lintStgConArg :: StgArg -> LintM ()
lintStgConArg StgArg
arg = do
Bool
unarised <- LintFlags -> Bool
lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
unarised (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ case Kind -> Maybe [PrimRep]
typePrimRep_maybe (StgArg -> Kind
stgArgType StgArg
arg) of
Just [PrimRep
_] -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe [PrimRep]
badRep -> SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Non-unary constructor arg: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgArg
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Its PrimReps are: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Maybe [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe [PrimRep]
badRep
case StgArg
arg of
StgLitArg Literal
_ -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
StgVarArg Id
v -> Id -> LintM ()
lintStgVar Id
v
lintStgFunArg :: StgArg -> LintM ()
lintStgFunArg :: StgArg -> LintM ()
lintStgFunArg StgArg
arg = do
Bool
unarised <- LintFlags -> Bool
lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
unarised (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ case Kind -> Maybe [PrimRep]
typePrimRep_maybe (StgArg -> Kind
stgArgType StgArg
arg) of
Just [] -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just [PrimRep
_] -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe [PrimRep]
badRep -> SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Function arg is not unary or void: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgArg
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Its PrimReps are: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Maybe [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe [PrimRep]
badRep
case StgArg
arg of
StgLitArg Literal
_ -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
StgVarArg Id
v -> Id -> LintM ()
lintStgVar Id
v
lintStgVar :: Id -> LintM ()
lintStgVar :: Id -> LintM ()
lintStgVar Id
id = Id -> LintM ()
checkInScope Id
id
lintStgBinds
:: (OutputablePass a, BinderP a ~ Id)
=> TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
top_lvl (StgNonRec BinderP a
binder GenStgRhs a
rhs) = do
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (Id
BinderP a
binder,GenStgRhs a
rhs)
[Id] -> LintM [Id]
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Id
BinderP a
binder]
lintStgBinds TopLevelFlag
top_lvl (StgRec [(BinderP a, GenStgRhs a)]
pairs)
= [Id] -> LintM [Id] -> LintM [Id]
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders (LintM [Id] -> LintM [Id]) -> LintM [Id] -> LintM [Id]
forall a b. (a -> b) -> a -> b
$ do
((Id, GenStgRhs a) -> LintM ()) -> [(Id, GenStgRhs a)] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl) [(Id, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs
[Id] -> LintM [Id]
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Id]
binders
where
binders :: [Id]
binders = [Id
b | (Id
b,GenStgRhs a
_) <- [(Id, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs]
lint_binds_help
:: (OutputablePass a, BinderP a ~ Id)
=> TopLevelFlag
-> (Id, GenStgRhs a)
-> LintM ()
lint_binds_help :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (Id
binder, GenStgRhs a
rhs)
= LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Id -> LintLocInfo
RhsOf Id
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 ~ Id) =>
GenStgRhs a -> LintM ()
checkNoCurrentCCS GenStgRhs a
rhs)
GenStgRhs a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
lintStgRhs GenStgRhs a
rhs
StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
Bool -> SDoc -> LintM ()
checkL ( Id -> Bool
isJoinId Id
binder
Bool -> Bool -> Bool
|| Bool -> Bool
not ((() :: Constraint) => Kind -> Bool
Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
binder))
Bool -> Bool -> Bool
|| Id -> Bool
isDataConWorkId Id
binder Bool -> Bool -> Bool
|| Id -> Bool
isDataConWrapId Id
binder)
(StgPprOpts -> Id -> GenStgRhs a -> SDoc
forall (a :: StgPass).
OutputablePass a =>
StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg StgPprOpts
opts Id
binder GenStgRhs a
rhs)
checkNoCurrentCCS
:: (OutputablePass a, BinderP a ~ Id)
=> GenStgRhs a
-> LintM ()
checkNoCurrentCCS :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
checkNoCurrentCCS GenStgRhs a
rhs = do
StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
let rhs' :: SDoc
rhs' = StgPprOpts -> GenStgRhs a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs
case GenStgRhs a
rhs of
StgRhsClosure XRhsClosure a
_ CostCentreStack
ccs UpdateFlag
_ [BinderP a]
_ GenStgExpr a
_
| CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
-> SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Top-level StgRhsClosure with CurrentCCS" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
rhs')
StgRhsCon CostCentreStack
ccs DataCon
_ ConstructorNumber
_ [StgTickish]
_ [StgArg]
_
| CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
-> SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Top-level StgRhsCon with CurrentCCS" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
rhs')
GenStgRhs a
_ -> () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
lintStgRhs :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
lintStgRhs (StgRhsClosure XRhsClosure a
_ CostCentreStack
_ UpdateFlag
_ [] GenStgExpr a
expr)
= GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
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 ([Id] -> LintLocInfo
LambdaBodyOf [Id]
[BinderP a]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
[Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
[BinderP a]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr
lintStgRhs rhs :: GenStgRhs a
rhs@(StgRhsCon CostCentreStack
_ DataCon
con ConstructorNumber
_ [StgTickish]
_ [StgArg]
args) = do
StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ do
SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgRhsCon is an unboxed tuple or sum application" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
StgPprOpts -> GenStgRhs a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)
DataCon -> [StgArg] -> SDoc -> LintM ()
lintConApp DataCon
con [StgArg]
args (StgPprOpts -> GenStgRhs a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)
lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
lintStgExpr :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr (StgLit Literal
_) = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintStgExpr e :: GenStgExpr a
e@(StgApp Id
fun [StgArg]
args) = do
Id -> LintM ()
lintStgVar Id
fun
(StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgFunArg [StgArg]
args
GenStgExpr a -> LintM ()
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> LintM ()
lintAppCbvMarks GenStgExpr a
e
Id -> [StgArg] -> LintM ()
lintStgAppReps Id
fun [StgArg]
args
lintStgExpr app :: GenStgExpr a
app@(StgConApp DataCon
con ConstructorNumber
_n [StgArg]
args [Kind]
_arg_tys) = do
LintFlags
lf <- LintM LintFlags
getLintFlags
let !unarised :: Bool
unarised = LintFlags -> Bool
lf_unarised LintFlags
lf
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
unarised Bool -> Bool -> Bool
&& DataCon -> Bool
isUnboxedSumDataCon DataCon
con) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ do
StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unboxed sum after unarise:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
StgPprOpts -> GenStgExpr a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
opts GenStgExpr a
app)
StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
DataCon -> [StgArg] -> SDoc -> LintM ()
lintConApp DataCon
con [StgArg]
args (StgPprOpts -> GenStgExpr a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
opts GenStgExpr a
app)
lintStgExpr (StgOpApp StgOp
_ [StgArg]
args Kind
_) =
(StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgFunArg [StgArg]
args
lintStgExpr (StgLet XLet a
_ GenStgBinding a
binds GenStgExpr a
body) = do
[Id]
binders <- TopLevelFlag -> GenStgBinding a -> LintM [Id]
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
NotTopLevel GenStgBinding a
binds
LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Id] -> LintLocInfo
BodyOfLetRec [Id]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
[Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
body
lintStgExpr (StgLetNoEscape XLetNoEscape a
_ GenStgBinding a
binds GenStgExpr a
body) = do
[Id]
binders <- TopLevelFlag -> GenStgBinding a -> LintM [Id]
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
NotTopLevel GenStgBinding a
binds
LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Id] -> LintLocInfo
BodyOfLetRec [Id]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
[Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
body
lintStgExpr (StgTick StgTickish
_ GenStgExpr a
expr) = GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
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 ~ Id) =>
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)
[Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id
BinderP a
bndr | Bool
in_scope] ((GenStgAlt a -> LintM ()) -> [GenStgAlt a] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenStgAlt a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgAlt a -> LintM ()
lintAlt [GenStgAlt a]
alts)
lintAlt
:: (OutputablePass a, BinderP a ~ Id)
=> GenStgAlt a -> LintM ()
lintAlt :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgAlt a -> LintM ()
lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = AltCon
DEFAULT
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP a]
_
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr a
rhs} = GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs
lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = LitAlt Literal
_
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP a]
_
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr a
rhs} = GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs
lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = DataAlt DataCon
_
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP a]
bndrs
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr a
rhs} =
do
(Id -> LintM ()) -> [Id] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> LintM ()
checkPostUnariseBndr [Id]
[BinderP a]
bndrs
[Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
[BinderP a]
bndrs (GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs)
lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM ()
lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM ()
lintConApp DataCon
con [StgArg]
args SDoc
app = do
(StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgConArg [StgArg]
args
Bool
unarised <- LintFlags -> Bool
lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
unarised Bool -> Bool -> Bool
&&
Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con) Bool -> Bool -> Bool
&&
[StrictnessMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((() :: Constraint) => DataCon -> [StrictnessMark]
DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ do
SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Constructor applied to incorrect number of arguments:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Application:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
app)
lintStgAppReps :: Id -> [StgArg] -> LintM ()
lintStgAppReps :: Id -> [StgArg] -> LintM ()
lintStgAppReps Id
_fun [] = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintStgAppReps Id
fun [StgArg]
args = do
LintFlags
lf <- LintM LintFlags
getLintFlags
let platform :: Platform
platform = LintFlags -> Platform
lf_platform LintFlags
lf
([Scaled Kind]
fun_arg_tys, Kind
_res) = Kind -> ([Scaled Kind], Kind)
splitFunTys (Id -> Kind
idType Id
fun)
fun_arg_tys' :: [Kind]
fun_arg_tys' = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing [Scaled Kind]
fun_arg_tys :: [Type]
fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = (Kind -> Maybe [PrimRep]) -> [Kind] -> [Maybe [PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Maybe [PrimRep]
typePrimRep_maybe [Kind]
fun_arg_tys'
actual_arg_reps :: [Maybe [PrimRep]]
actual_arg_reps = (StgArg -> Maybe [PrimRep]) -> [StgArg] -> [Maybe [PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Maybe [PrimRep]
typePrimRep_maybe (Kind -> Maybe [PrimRep])
-> (StgArg -> Kind) -> StgArg -> Maybe [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Kind
stgArgType) [StgArg]
args
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args (Maybe [PrimRep]
Nothing:[Maybe [PrimRep]]
_) [Maybe [PrimRep]]
_ = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
match_args ([Maybe [PrimRep]]
_) (Maybe [PrimRep]
Nothing:[Maybe [PrimRep]]
_) = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
match_args (Just [PrimRep]
actual_rep:[Maybe [PrimRep]]
actual_reps_left) (Just [PrimRep]
expected_rep:[Maybe [PrimRep]]
expected_reps_left)
| [PrimRep]
actual_rep [PrimRep] -> [PrimRep] -> Bool
forall a. Eq a => a -> a -> Bool
== [PrimRep]
expected_rep
= [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_reps_left [Maybe [PrimRep]]
expected_reps_left
| [PrimRep] -> Bool
isVoidRep [PrimRep]
actual_rep Bool -> Bool -> Bool
&& [PrimRep] -> Bool
isVoidRep [PrimRep]
expected_rep
= [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_reps_left [Maybe [PrimRep]]
expected_reps_left
| Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible Platform
platform [PrimRep]
actual_rep [PrimRep]
expected_rep
= [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_reps_left [Maybe [PrimRep]]
expected_reps_left
| Just (PrimRep
actual,[Maybe [PrimRep]]
actuals) <- [PrimRep]
-> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [PrimRep]
actual_rep [Maybe [PrimRep]]
actual_reps_left
, Just (PrimRep
expected,[Maybe [PrimRep]]
expecteds) <- [PrimRep]
-> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [PrimRep]
expected_rep [Maybe [PrimRep]]
expected_reps_left
, Platform -> PrimRep -> PrimRep -> Bool
primRepCompatible Platform
platform PrimRep
actual PrimRep
expected
= [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actuals [Maybe [PrimRep]]
expecteds
| Bool
otherwise = SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Function type reps and function argument reps mismatched") Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In application " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argument rep:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Maybe [PrimRep]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Maybe [PrimRep]]
actual_arg_reps SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expected rep:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Maybe [PrimRep]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Maybe [PrimRep]]
fun_arg_tys_reps SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unarised?:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LintFlags -> Bool
lf_unarised LintFlags
lf))
where
isVoidRep :: [PrimRep] -> Bool
isVoidRep [] = Bool
True
isVoidRep [PrimRep
VoidRep] = Bool
True
isVoidRep [PrimRep]
_ = Bool
False
getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep :: [PrimRep]
-> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [] [Maybe [PrimRep]]
_rest = Maybe (PrimRep, [Maybe [PrimRep]])
forall a. Maybe a
Nothing
getOneRep [PrimRep
rep] [Maybe [PrimRep]]
rest = (PrimRep, [Maybe [PrimRep]]) -> Maybe (PrimRep, [Maybe [PrimRep]])
forall a. a -> Maybe a
Just (PrimRep
rep,[Maybe [PrimRep]]
rest)
getOneRep (PrimRep
rep:[PrimRep]
reps) [Maybe [PrimRep]]
rest = (PrimRep, [Maybe [PrimRep]]) -> Maybe (PrimRep, [Maybe [PrimRep]])
forall a. a -> Maybe a
Just (PrimRep
rep,[PrimRep] -> Maybe [PrimRep]
forall a. a -> Maybe a
Just [PrimRep]
repsMaybe [PrimRep] -> [Maybe [PrimRep]] -> [Maybe [PrimRep]]
forall a. a -> [a] -> [a]
:[Maybe [PrimRep]]
rest)
match_args [Maybe [PrimRep]]
_ [Maybe [PrimRep]]
_ = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_arg_reps [Maybe [PrimRep]]
fun_arg_tys_reps
lintAppCbvMarks :: OutputablePass pass
=> GenStgExpr pass -> LintM ()
lintAppCbvMarks :: forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> LintM ()
lintAppCbvMarks e :: GenStgExpr pass
e@(StgApp Id
fun [StgArg]
args) = 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
$ do
let marks :: [CbvMark]
marks = [CbvMark] -> Maybe [CbvMark] -> [CbvMark]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
forall a b. (a -> b) -> a -> b
$ Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fun
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CbvMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((CbvMark -> Bool) -> [CbvMark] -> [CbvMark]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (Bool -> Bool
not (Bool -> Bool) -> (CbvMark -> Bool) -> CbvMark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CbvMark -> Bool
isMarkedCbv) [CbvMark]
marks) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ do
SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Undersatured cbv marked ID in App" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
e ) Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"marks" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CbvMark]
marks SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Int
idArity Id
fun) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"join_arity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Maybe Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe Int
isJoinId_maybe Id
fun))
lintAppCbvMarks GenStgExpr pass
_ = String -> LintM ()
forall a. HasCallStack => String -> a
panic String
"impossible - lintAppCbvMarks"
newtype LintM a = LintM
{ forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM :: Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
}
deriving ((forall a b. (a -> b) -> LintM a -> LintM b)
-> (forall a b. a -> LintM b -> LintM a) -> Functor LintM
forall a b. a -> LintM b -> LintM a
forall a b. (a -> b) -> LintM a -> LintM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
fmap :: forall a b. (a -> b) -> LintM a -> LintM b
$c<$ :: forall a b. a -> LintM b -> LintM a
<$ :: forall a b. a -> LintM b -> LintM a
Functor)
data LintFlags = LintFlags { LintFlags -> Bool
lf_unarised :: !Bool
, LintFlags -> Platform
lf_platform :: !Platform
}
data LintLocInfo
= RhsOf Id
| LambdaBodyOf [Id]
| BodyOfLetRec [Id]
dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc (RhsOf Id
v) =
(SrcLoc -> SrcSpan
srcLocSpan (Id -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Id
v), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" [RHS of " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Id] -> SDoc
pp_binders [Id
v] SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
']' )
dumpLoc (LambdaBodyOf [Id]
bs) =
(SrcLoc -> SrcSpan
srcLocSpan (Id -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc ([Id] -> Id
forall a. HasCallStack => [a] -> a
head [Id]
bs)), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" [in body of lambda with binders " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Id] -> SDoc
pp_binders [Id]
bs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
']' )
dumpLoc (BodyOfLetRec [Id]
bs) =
(SrcLoc -> SrcSpan
srcLocSpan (Id -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc ([Id] -> Id
forall a. HasCallStack => [a] -> a
head [Id]
bs)), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" [in body of letrec with binders " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Id] -> SDoc
pp_binders [Id]
bs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
']' )
pp_binders :: [Id] -> SDoc
pp_binders :: [Id] -> SDoc
pp_binders [Id]
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 ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
pp_binder [Id]
bs))
where
pp_binder :: Id -> SDoc
pp_binder Id
b
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b, SDoc
dcolon, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
b)]
initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
initL :: forall a.
Platform
-> DiagOpts
-> Module
-> Bool
-> StgPprOpts
-> IdSet
-> LintM a
-> Maybe SDoc
initL Platform
platform DiagOpts
diag_opts Module
this_mod Bool
unarised StgPprOpts
opts IdSet
locals (LintM Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
m) = do
let (a
_, Bag SDoc
errs) = Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
m Module
this_mod (Bool -> Platform -> LintFlags
LintFlags Bool
unarised Platform
platform) DiagOpts
diag_opts StgPprOpts
opts [] IdSet
locals Bag SDoc
forall a. Bag a
emptyBag
if Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs then
Maybe SDoc
forall a. Maybe a
Nothing
else
SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
blankLine (Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
errs)))
instance Applicative LintM where
pure :: forall a. a -> LintM a
pure a
a = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf DiagOpts
_df StgPprOpts
_opts [LintLocInfo]
_loc IdSet
_scope Bag SDoc
errs -> (a
a, Bag SDoc
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
*> :: forall a b. 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
>>= :: forall a b. 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
>> :: forall a b. LintM a -> LintM b -> LintM b
(>>) = LintM a -> LintM b -> LintM b
forall a 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 :: forall a b. LintM a -> (a -> LintM b) -> LintM b
thenL LintM a
m a -> LintM b
k = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc))
-> LintM b
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc))
-> LintM b)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc))
-> LintM b
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
-> case LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs of
(a
r, Bag SDoc
errs') -> LintM b
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM (a -> LintM b
k a
r) Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs'
thenL_ :: LintM a -> LintM b -> LintM b
thenL_ :: forall a b. LintM a -> LintM b -> LintM b
thenL_ LintM a
m LintM b
k = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc))
-> LintM b
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc))
-> LintM b)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc))
-> LintM b
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
-> case LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs of
(a
_, Bag SDoc
errs') -> LintM b
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM b
k Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
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 ()
addErrL SDoc
msg
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr Id
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_ (Id -> Maybe String
checkPostUnariseId Id
bndr) ((String -> LintM ()) -> LintM ())
-> (String -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \String
unexpected ->
SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"After unarisation, binder " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" has " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
unexpected SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
bndr)
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId Id
id
| Kind -> Bool
isUnboxedSumType Kind
id_ty = String -> Maybe String
forall a. a -> Maybe a
Just String
"unboxed sum"
| Kind -> Bool
isUnboxedTupleType Kind
id_ty = String -> Maybe String
forall a. a -> Maybe a
Just String
"unboxed tuple"
| (() :: Constraint) => Kind -> Bool
Kind -> Bool
isZeroBitTy Kind
id_ty = String -> Maybe String
forall a. a -> Maybe a
Just String
"void"
| Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
where
id_ty :: Kind
id_ty = Id -> Kind
idType Id
id
addErrL :: SDoc -> LintM ()
addErrL :: SDoc -> LintM ()
addErrL SDoc
msg = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> ((), Bag SDoc))
-> LintM ()
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> ((), Bag SDoc))
-> LintM ())
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> ((), Bag SDoc))
-> LintM ()
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf DiagOpts
df StgPprOpts
_opts [LintLocInfo]
loc IdSet
_scope Bag SDoc
errs -> ((), DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr DiagOpts
df Bag SDoc
errs SDoc
msg [LintLocInfo]
loc)
addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr DiagOpts
diag_opts Bag SDoc
errs_so_far SDoc
msg [LintLocInfo]
locs
= Bag SDoc
errs_so_far Bag SDoc -> SDoc -> Bag SDoc
forall a. Bag a -> a -> Bag a
`snocBag` [LintLocInfo] -> SDoc
mk_msg [LintLocInfo]
locs
where
mk_msg :: [LintLocInfo] -> SDoc
mk_msg (LintLocInfo
loc:[LintLocInfo]
_) = let (SrcSpan
l,SDoc
hdr) = LintLocInfo -> (SrcSpan, SDoc)
dumpLoc LintLocInfo
loc
in MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage (DiagOpts
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
Err.mkMCDiagnostic DiagOpts
diag_opts DiagnosticReason
WarningWithoutFlag Maybe DiagnosticCode
forall a. Maybe a
Nothing)
SrcSpan
l (SDoc
hdr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
msg)
mk_msg [] = SDoc
msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc :: forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
extra_loc LintM a
m = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
-> LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts (LintLocInfo
extra_locLintLocInfo -> [LintLocInfo] -> [LintLocInfo]
forall a. a -> [a] -> [a]
:[LintLocInfo]
loc) IdSet
scope Bag SDoc
errs
addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars :: forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
ids LintM a
m = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
-> let
new_set :: IdSet
new_set = [Id] -> IdSet
mkVarSet [Id]
ids
in LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc (IdSet
scope IdSet -> IdSet -> IdSet
`unionVarSet` IdSet
new_set) Bag SDoc
errs
getLintFlags :: LintM LintFlags
getLintFlags :: LintM LintFlags
getLintFlags = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (LintFlags, Bag SDoc))
-> LintM LintFlags
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (LintFlags, Bag SDoc))
-> LintM LintFlags)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (LintFlags, Bag SDoc))
-> LintM LintFlags
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
lf DiagOpts
_df StgPprOpts
_opts [LintLocInfo]
_loc IdSet
_scope Bag SDoc
errs -> (LintFlags
lf, Bag SDoc
errs)
getStgPprOpts :: LintM StgPprOpts
getStgPprOpts :: LintM StgPprOpts
getStgPprOpts = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (StgPprOpts, Bag SDoc))
-> LintM StgPprOpts
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (StgPprOpts, Bag SDoc))
-> LintM StgPprOpts)
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (StgPprOpts, Bag SDoc))
-> LintM StgPprOpts
forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf DiagOpts
_df StgPprOpts
opts [LintLocInfo]
_loc IdSet
_scope Bag SDoc
errs -> (StgPprOpts
opts, Bag SDoc
errs)
checkInScope :: Id -> LintM ()
checkInScope :: Id -> LintM ()
checkInScope Id
id = (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> ((), Bag SDoc))
-> LintM ()
forall a.
(Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc))
-> LintM a
LintM ((Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> ((), Bag SDoc))
-> LintM ())
-> (Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> ((), Bag SDoc))
-> LintM ()
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
_lf DiagOpts
diag_opts StgPprOpts
_opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
-> if Module -> Name -> Bool
nameIsLocalOrFrom Module
mod (Id -> Name
idName Id
id) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id
id Id -> IdSet -> Bool
`elemVarSet` IdSet
scope) then
((), DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr DiagOpts
diag_opts Bag SDoc
errs ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id, SDoc
dcolon, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id),
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is out of scope"]) [LintLocInfo]
loc)
else
((), Bag SDoc
errs)
mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg :: forall (a :: StgPass).
OutputablePass a =>
StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg StgPprOpts
opts Id
binder GenStgRhs a
rhs
= (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Let(rec) binder" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
binder) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has unlifted type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
binder)))
SDoc -> SDoc -> SDoc
forall doc. IsDoc 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
<+> StgPprOpts -> GenStgRhs a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)