{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 810
#define REASON NoReason
#else
#define REASON
#endif
#if __GLASGOW_HASKELL__ >= 900
#define VARBINDARG
#else
#define VARBINDARG _
#endif
module CoreWarn (plugin) where
import Warn.Coercion
import Warn.Dictionary
import Control.Monad
import Data.Bool (bool)
import Data.Foldable
import Data.Graph.Good
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Monoid
import GHC (GhcTc)
import Generics.SYB
import Prelude hiding (lookup)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Map as M
import qualified Data.Set as S
#if __GLASGOW_HASKELL__ >= 900
import GHC.Core.Stats
import GHC.Plugins hiding (typeSize, (<>))
import GHC.Tc.Types (tcg_binds)
import Data.List (nub)
#else
import Data.Containers.ListUtils (nubOrd)
import CoreStats
import GhcPlugins hiding (typeSize, (<>))
import TcRnMonad (tcg_binds)
#endif
#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs.Expr
import GHC.Hs.Binds
#else
import HsExpr
import HsBinds
#endif
plugin :: Plugin
plugin :: Plugin
plugin =
Plugin
defaultPlugin
{ installCoreToDos :: CorePlugin
installCoreToDos = \ss :: [CommandLineOption]
ss ctds :: [CoreToDo]
ctds -> do
LHsBinds GhcTc
binds <- IO (LHsBinds GhcTc) -> CoreM (LHsBinds GhcTc)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LHsBinds GhcTc) -> CoreM (LHsBinds GhcTc))
-> IO (LHsBinds GhcTc) -> CoreM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ IORef (LHsBinds GhcTc) -> IO (LHsBinds GhcTc)
forall a. IORef a -> IO a
readIORef IORef (LHsBinds GhcTc)
global_tcg_ref
[CoreToDo] -> CoreM [CoreToDo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreToDo] -> CoreM [CoreToDo]) -> [CoreToDo] -> CoreM [CoreToDo]
forall a b. (a -> b) -> a -> b
$ [CoreToDo]
ctds [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [CoreWarnOpts -> LHsBinds GhcTc -> CoreToDo
coreWarn ([CommandLineOption] -> CoreWarnOpts
parseOpts [CommandLineOption]
ss) LHsBinds GhcTc
binds]
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = IO PluginRecompile -> [CommandLineOption] -> IO PluginRecompile
forall a b. a -> b -> a
const (IO PluginRecompile -> [CommandLineOption] -> IO PluginRecompile)
-> IO PluginRecompile -> [CommandLineOption] -> IO PluginRecompile
forall a b. (a -> b) -> a -> b
$ PluginRecompile -> IO PluginRecompile
forall (f :: * -> *) a. Applicative f => a -> f a
pure PluginRecompile
NoForceRecompile
, typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction = \_ _ tcg :: TcGblEnv
tcg -> do
IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef (LHsBinds GhcTc) -> LHsBinds GhcTc -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (LHsBinds GhcTc)
global_tcg_ref (LHsBinds GhcTc -> IO ()) -> LHsBinds GhcTc -> IO ()
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcg
TcGblEnv -> TcM TcGblEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcGblEnv
tcg
}
global_tcg_ref :: IORef (LHsBinds GhcTc)
global_tcg_ref :: IORef (LHsBinds GhcTc)
global_tcg_ref = IO (IORef (LHsBinds GhcTc)) -> IORef (LHsBinds GhcTc)
forall a. IO a -> a
unsafePerformIO (IO (IORef (LHsBinds GhcTc)) -> IORef (LHsBinds GhcTc))
-> IO (IORef (LHsBinds GhcTc)) -> IORef (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcTc -> IO (IORef (LHsBinds GhcTc))
forall a. a -> IO (IORef a)
newIORef (LHsBinds GhcTc -> IO (IORef (LHsBinds GhcTc)))
-> LHsBinds GhcTc -> IO (IORef (LHsBinds GhcTc))
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> LHsBinds GhcTc
forall a. HasCallStack => CommandLineOption -> a
error "no tcg_binds set"
{-# NOINLINE global_tcg_ref #-}
data CoreWarnOpts = CoreWarnOpts
{ CoreWarnOpts -> Endo Bool
cwo_warnBigCoerces :: Endo Bool,
CoreWarnOpts -> Endo Bool
cwo_warnDeepDicts :: Endo Bool
}
instance Semigroup CoreWarnOpts where
<> :: CoreWarnOpts -> CoreWarnOpts -> CoreWarnOpts
(<>) (CoreWarnOpts lb4 :: Endo Bool
lb4 lb5 :: Endo Bool
lb5) (CoreWarnOpts lb :: Endo Bool
lb lb3 :: Endo Bool
lb3) =
CoreWarnOpts :: Endo Bool -> Endo Bool -> CoreWarnOpts
CoreWarnOpts
{ cwo_warnBigCoerces :: Endo Bool
cwo_warnBigCoerces = Endo Bool
lb Endo Bool -> Endo Bool -> Endo Bool
forall a. Semigroup a => a -> a -> a
<> Endo Bool
lb4,
cwo_warnDeepDicts :: Endo Bool
cwo_warnDeepDicts = Endo Bool
lb3 Endo Bool -> Endo Bool -> Endo Bool
forall a. Semigroup a => a -> a -> a
<> Endo Bool
lb5
}
instance Monoid CoreWarnOpts where
mempty :: CoreWarnOpts
mempty =
CoreWarnOpts :: Endo Bool -> Endo Bool -> CoreWarnOpts
CoreWarnOpts
{ cwo_warnBigCoerces :: Endo Bool
cwo_warnBigCoerces = Endo Bool
forall a. Monoid a => a
mempty,
cwo_warnDeepDicts :: Endo Bool
cwo_warnDeepDicts = Endo Bool
forall a. Monoid a => a
mempty
}
parseOpts :: [CommandLineOption] -> CoreWarnOpts
parseOpts :: [CommandLineOption] -> CoreWarnOpts
parseOpts = [CommandLineOption] -> CoreWarnOpts
go
where
go :: [CommandLineOption] -> CoreWarnOpts
go = (CommandLineOption -> CoreWarnOpts)
-> [CommandLineOption] -> CoreWarnOpts
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((CommandLineOption -> CoreWarnOpts)
-> [CommandLineOption] -> CoreWarnOpts)
-> (CommandLineOption -> CoreWarnOpts)
-> [CommandLineOption]
-> CoreWarnOpts
forall a b. (a -> b) -> a -> b
$ \case
"warn-large-coercions" -> Endo Bool -> Endo Bool -> CoreWarnOpts
CoreWarnOpts ((Bool -> Bool) -> Endo Bool
forall a. (a -> a) -> Endo a
Endo ((Bool -> Bool) -> Endo Bool) -> (Bool -> Bool) -> Endo Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) Endo Bool
forall a. Monoid a => a
mempty
"no-warn-large-coercions" -> Endo Bool -> Endo Bool -> CoreWarnOpts
CoreWarnOpts ((Bool -> Bool) -> Endo Bool
forall a. (a -> a) -> Endo a
Endo ((Bool -> Bool) -> Endo Bool) -> (Bool -> Bool) -> Endo Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) Endo Bool
forall a. Monoid a => a
mempty
"warn-deep-dicts" -> Endo Bool -> Endo Bool -> CoreWarnOpts
CoreWarnOpts Endo Bool
forall a. Monoid a => a
mempty ((Bool -> Bool) -> Endo Bool
forall a. (a -> a) -> Endo a
Endo ((Bool -> Bool) -> Endo Bool) -> (Bool -> Bool) -> Endo Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
"no-warn-deep-dicts" -> Endo Bool -> Endo Bool -> CoreWarnOpts
CoreWarnOpts Endo Bool
forall a. Monoid a => a
mempty ((Bool -> Bool) -> Endo Bool
forall a. (a -> a) -> Endo a
Endo ((Bool -> Bool) -> Endo Bool) -> (Bool -> Bool) -> Endo Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
_ -> CoreWarnOpts
forall a. Monoid a => a
mempty
findDictRef :: Data a => OccName -> a -> [SrcSpan]
findDictRef :: OccName -> a -> [SrcSpan]
findDictRef occ :: OccName
occ = ([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> GenericQ [SrcSpan] -> GenericQ [SrcSpan]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
(<>) (GenericQ [SrcSpan] -> a -> [SrcSpan])
-> GenericQ [SrcSpan] -> a -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ [SrcSpan]
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [SrcSpan])
-> a
-> [SrcSpan]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [SrcSpan]
forall a. Monoid a => a
mempty ((GenLocated SrcSpan (HsExpr GhcTc) -> [SrcSpan])
-> a -> [SrcSpan])
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [SrcSpan])
-> a
-> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ \case
#if __GLASGOW_HASKELL__ >= 900
L loc (XExpr (WrapExpr ev))
#else
L loc :: SrcSpan
loc (HsWrap _ ev :: HsWrapper
ev _)
#endif
| SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc ->
([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> GenericQ [SrcSpan] -> HsWrapper -> [SrcSpan]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
(<>)
([SrcSpan] -> (Var -> [SrcSpan]) -> a -> [SrcSpan]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [SrcSpan]
forall a. Monoid a => a
mempty ((Var -> [SrcSpan]) -> a -> [SrcSpan])
-> (Var -> [SrcSpan]) -> a -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ \(Var
v :: Var) -> [SrcSpan] -> [SrcSpan] -> Bool -> [SrcSpan]
forall a. a -> a -> Bool -> a
bool [] [SrcSpan
loc] (Bool -> [SrcSpan]) -> Bool -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ Var -> OccName
forall a. NamedThing a => a -> OccName
getOccName Var
v OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ)
HsWrapper
ev
(GenLocated SrcSpan (HsExpr GhcTc)
_ :: LHsExpr GhcTc) -> []
findBindCoercions :: Data a => Name -> a -> [SrcSpan]
findBindCoercions :: Name -> a -> [SrcSpan]
findBindCoercions occ :: Name
occ = ([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> GenericQ [SrcSpan] -> GenericQ [SrcSpan]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
(<>) (GenericQ [SrcSpan] -> a -> [SrcSpan])
-> GenericQ [SrcSpan] -> a -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ [SrcSpan] -> (HsBindLR GhcTc GhcTc -> [SrcSpan]) -> a -> [SrcSpan]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [SrcSpan]
forall a. Monoid a => a
mempty ((HsBindLR GhcTc GhcTc -> [SrcSpan]) -> a -> [SrcSpan])
-> (HsBindLR GhcTc GhcTc -> [SrcSpan]) -> a -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ \case
x :: HsBindLR GhcTc GhcTc
x@(VarBind _ a :: IdP GhcTc
a _ VARBINDARG)
| Var -> Name
forall a. NamedThing a => a -> Name
getName IdP GhcTc
Var
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
occ ->
HsBindLR GhcTc GhcTc -> [SrcSpan]
GenericQ [SrcSpan]
get_sub HsBindLR GhcTc GhcTc
x
x :: HsBindLR GhcTc GhcTc
x@(FunBind _ (L _ a :: IdP GhcTc
a) _ _ VARBINDARG)
| Var -> Name
forall a. NamedThing a => a -> Name
getName IdP GhcTc
Var
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
occ ->
HsBindLR GhcTc GhcTc -> [SrcSpan]
GenericQ [SrcSpan]
get_sub HsBindLR GhcTc GhcTc
x
x :: HsBindLR GhcTc GhcTc
x@(AbsBinds _ _ b :: [Var]
b e :: [ABExport GhcTc]
e _ _ _)
| (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
occ) (Name -> Bool) -> (Var -> Name) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Name
forall a. NamedThing a => a -> Name
getName) [Var]
b
Bool -> Bool -> Bool
|| (ABExport GhcTc -> Bool) -> [ABExport GhcTc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
occ) (Name -> Bool)
-> (ABExport GhcTc -> Name) -> ABExport GhcTc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Name
forall a. NamedThing a => a -> Name
getName (Var -> Name) -> (ABExport GhcTc -> Var) -> ABExport GhcTc -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ABExport GhcTc -> Var
forall p. ABExport p -> IdP p
abe_poly) [ABExport GhcTc]
e -> HsBindLR GhcTc GhcTc -> [SrcSpan]
GenericQ [SrcSpan]
get_sub HsBindLR GhcTc GhcTc
x
(HsBindLR GhcTc GhcTc
_ :: HsBindLR GhcTc GhcTc) -> []
where
get_sub :: a -> [SrcSpan]
get_sub x :: a
x =
([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> GenericQ [SrcSpan] -> a -> [SrcSpan]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
(<>) ([SrcSpan]
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [SrcSpan])
-> a
-> [SrcSpan]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [SrcSpan]
forall a. Monoid a => a
mempty ((GenLocated SrcSpan (HsExpr GhcTc) -> [SrcSpan])
-> a -> [SrcSpan])
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [SrcSpan])
-> a
-> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ \case
#if __GLASGOW_HASKELL__ >= 900
L loc (XExpr (WrapExpr y))
#else
L loc :: SrcSpan
loc (HsWrap _ y :: HsWrapper
y _)
#endif
| SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc
, Coercion -> HsWrapper -> Int
forall a. Typeable a => a -> GenericQ Int
gtypecount (Coercion
forall a. HasCallStack => a
undefined :: Coercion) HsWrapper
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 -> [SrcSpan
loc]
(GenLocated SrcSpan (HsExpr GhcTc)
_ :: LHsExpr GhcTc) -> []
) a
x
singletonIfEmpty :: a -> [a] -> [a]
singletonIfEmpty :: a -> [a] -> [a]
singletonIfEmpty a :: a
a as :: [a]
as = if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
as then [a
a] else [a]
as
isDictVar :: CoreBndr -> Bool
isDictVar :: Var -> Bool
isDictVar bndr :: Var
bndr = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
(tycon :: TyCon
tycon, _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Maybe (TyCon, [Type])) -> Type -> Maybe (TyCon, [Type])
forall a b. (a -> b) -> a -> b
$ Var -> Type
idType Var
bndr
Class
_cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tycon
Bool -> Maybe Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
coreBndrToExprMap :: Bind CoreBndr -> M.Map CoreBndr CoreExpr
coreBndrToExprMap :: Bind Var -> Map Var CoreExpr
coreBndrToExprMap (NonRec var :: Var
var ex :: CoreExpr
ex) = Var -> CoreExpr -> Map Var CoreExpr
forall k a. k -> a -> Map k a
M.singleton Var
var CoreExpr
ex
coreBndrToExprMap (Rec ex :: [(Var, CoreExpr)]
ex) = ((Var, CoreExpr) -> Map Var CoreExpr)
-> [(Var, CoreExpr)] -> Map Var CoreExpr
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Var -> CoreExpr -> Map Var CoreExpr)
-> (Var, CoreExpr) -> Map Var CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Var -> CoreExpr -> Map Var CoreExpr
forall k a. k -> a -> Map k a
M.singleton) [(Var, CoreExpr)]
ex
coreWarn :: CoreWarnOpts -> LHsBinds GhcTc -> CoreToDo
coreWarn :: CoreWarnOpts -> LHsBinds GhcTc -> CoreToDo
coreWarn opts :: CoreWarnOpts
opts binds :: LHsBinds GhcTc
binds = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass "coercionCheck" (CorePluginPass -> CoreToDo) -> CorePluginPass -> CoreToDo
forall a b. (a -> b) -> a -> b
$ \guts :: ModGuts
guts -> do
let programMap :: Map Var CoreExpr
programMap = (Bind Var -> Map Var CoreExpr) -> [Bind Var] -> Map Var CoreExpr
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Bind Var -> Map Var CoreExpr
coreBndrToExprMap ([Bind Var] -> Map Var CoreExpr) -> [Bind Var] -> Map Var CoreExpr
forall a b. (a -> b) -> a -> b
$ ModGuts -> [Bind Var]
mg_binds ModGuts
guts
dictSets :: [Set Var]
dictSets = (Tree Var -> Set Var) -> [Tree Var] -> [Set Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList ([Var] -> Set Var) -> (Tree Var -> [Var]) -> Tree Var -> Set Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Var -> [Var]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
([Tree Var] -> [Set Var])
-> (Map Var CoreExpr -> [Tree Var])
-> Map Var CoreExpr
-> [Set Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph Var -> [Tree Var]
forall v. Graph v -> Forest v
components
(Graph Var -> [Tree Var])
-> (Map Var CoreExpr -> Graph Var)
-> Map Var CoreExpr
-> [Tree Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Var, [Var])] -> Graph Var
forall v. Ord v => [(v, [v])] -> Graph v
graphFromEdges
([(Var, [Var])] -> Graph Var)
-> (Map Var CoreExpr -> [(Var, [Var])])
-> Map Var CoreExpr
-> Graph Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Var, [Var]) -> Bool) -> [(Var, [Var])] -> [(Var, [Var])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var -> Bool
isDictVar (Var -> Bool) -> ((Var, [Var]) -> Var) -> (Var, [Var]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, [Var]) -> Var
forall a b. (a, b) -> a
fst)
([(Var, [Var])] -> [(Var, [Var])])
-> (Map Var CoreExpr -> [(Var, [Var])])
-> Map Var CoreExpr
-> [(Var, [Var])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Var [Var] -> [(Var, [Var])]
forall k a. Map k a -> [(k, a)]
M.toList (Map Var [Var] -> [(Var, [Var])])
-> (Map Var CoreExpr -> Map Var [Var])
-> Map Var CoreExpr
-> [(Var, [Var])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Var -> [Var]) -> Map Var (Set Var) -> Map Var [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Var -> [Var]
forall a. Set a -> [a]
S.toList
(Map Var (Set Var) -> Map Var [Var])
-> (Map Var CoreExpr -> Map Var (Set Var))
-> Map Var CoreExpr
-> Map Var [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Var CoreExpr -> Map Var (Set Var)
mkCoreAdjacencyMap
(Map Var CoreExpr -> [Set Var]) -> Map Var CoreExpr -> [Set Var]
forall a b. (a -> b) -> a -> b
$ Map Var CoreExpr
programMap
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Endo Bool -> Bool -> Bool) -> Bool -> Endo Bool -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo Bool -> Bool -> Bool
forall a. Endo a -> a -> a
appEndo Bool
True (Endo Bool -> Bool) -> Endo Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CoreWarnOpts -> Endo Bool
cwo_warnDeepDicts CoreWarnOpts
opts) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
[Set Var] -> (Set Var -> CoreM ()) -> CoreM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Set Var]
dictSets \dictSet :: Set Var
dictSet -> do
let srcSpans :: [SrcSpan]
srcSpans
= (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter SrcSpan -> Bool
isGoodSrcSpan
([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ (OccName -> [SrcSpan]) -> Set OccName -> [SrcSpan]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((OccName -> LHsBinds GhcTc -> [SrcSpan])
-> LHsBinds GhcTc -> OccName -> [SrcSpan]
forall a b c. (a -> b -> c) -> b -> a -> c
flip OccName -> LHsBinds GhcTc -> [SrcSpan]
forall a. Data a => OccName -> a -> [SrcSpan]
findDictRef LHsBinds GhcTc
binds)
(Set OccName -> [SrcSpan]) -> Set OccName -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ (Var -> Set OccName) -> Set Var -> Set OccName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OccName -> Set OccName
forall a. a -> Set a
S.singleton (OccName -> Set OccName) -> (Var -> OccName) -> Var -> Set OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> OccName
forall name. HasOccName name => name -> OccName
occName) Set Var
dictSet
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Var -> Bool
shouldWarnDeepDict Set Var
dictSet) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> CoreM ()
warnMsg REASON $
[SrcSpan] -> Set Var -> SDoc
pprDeepDict [SrcSpan]
srcSpans Set Var
dictSet
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Endo Bool -> Bool -> Bool) -> Bool -> Endo Bool -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo Bool -> Bool -> Bool
forall a. Endo a -> a -> a
appEndo Bool
True (Endo Bool -> Bool) -> Endo Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CoreWarnOpts -> Endo Bool
cwo_warnBigCoerces CoreWarnOpts
opts) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
[(Var, CoreStats)] -> ((Var, CoreStats) -> CoreM ()) -> CoreM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map Var CoreStats -> [(Var, CoreStats)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Var CoreStats -> [(Var, CoreStats)])
-> (Map Var CoreExpr -> Map Var CoreStats)
-> Map Var CoreExpr
-> [(Var, CoreStats)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> CoreStats) -> Map Var CoreExpr -> Map Var CoreStats
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoreExpr -> CoreStats
exprStats (Map Var CoreExpr -> [(Var, CoreStats)])
-> Map Var CoreExpr -> [(Var, CoreStats)]
forall a b. (a -> b) -> a -> b
$ Map Var CoreExpr
programMap) \(coreBndr :: Var
coreBndr, coreStats :: CoreStats
coreStats) ->
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CoreStats -> Bool
shouldWarnLargeCoercion CoreStats
coreStats) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> CoreM ()
warnMsg REASON $
[SrcSpan] -> Var -> CoreStats -> SDoc
pprWarnLargeCoerce
(SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
singletonIfEmpty SrcSpan
noSrcSpan ([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 900
nub
#else
[SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
nubOrd
#endif
([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ Name -> LHsBinds GhcTc -> [SrcSpan]
forall a. Data a => Name -> a -> [SrcSpan]
findBindCoercions (Var -> Name
forall a. NamedThing a => a -> Name
getName Var
coreBndr) LHsBinds GhcTc
binds)
Var
coreBndr
CoreStats
coreStats
CorePluginPass
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModGuts
guts