{-# 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

------------------------------------------------------------------------------
-- | The main @core-warn@ program.
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
    }


------------------------------------------------------------------------------
-- | We need to get our grubby little hands on the 'tcg_binds', but the
-- core-to-core plugin interface doesn't give us access to them. So we do this
-- very safe trick to get a hold of them.
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 #-}


------------------------------------------------------------------------------
-- | Options for @core-warn@. These are opt-out.
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
      }


------------------------------------------------------------------------------
-- | Parse options.
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


------------------------------------------------------------------------------
-- | Given an 'OccName' corresponding to a dictionary, find every immediate
-- 'SrcSpan's that contain it.
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) -> []


------------------------------------------------------------------------------
-- | Given an 'OccName', find the src span for every coercion inside of its
-- definition.
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


------------------------------------------------------------------------------
-- | Like 'fromMaybe' but for lists.
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


------------------------------------------------------------------------------
-- | Is this 'CoreBndr' the 'Var' of a dictionary?
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


------------------------------------------------------------------------------
-- | Translatea @'Bind' 'CoreBndr'@ into a map from 'CoreBndr's to 'CoreExpr's.
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


------------------------------------------------------------------------------
-- | The @core-warn@ todo pass.
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
              -- TODO(sandy): I know it's slow, but blame GHC9 for getting rid
              -- of the 'Ord' instance on 'SrcSpan
              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