{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module PinnedWarnings
  ( plugin
  ) where

import           Control.Concurrent.MVar
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.IORef
#if !MIN_VERSION_ghc(9,10,0)
import           Data.List
#endif
import qualified Data.Map.Strict as M
import           Data.Maybe
import qualified Data.Set as S
import           Data.String (fromString)
import qualified System.Directory as Dir
import           System.IO.Unsafe (unsafePerformIO)

import qualified Internal.FixWarnings as FW
import qualified Internal.GhcFacade as Ghc
import           Internal.Types

-- | A mutable global variable used to track warnings during and after
-- compilations.
globalState :: MVar (M.Map ModuleFile WarningsWithModDate)
globalState :: MVar (Map ModuleFile WarningsWithModDate)
globalState = IO (MVar (Map ModuleFile WarningsWithModDate))
-> MVar (Map ModuleFile WarningsWithModDate)
forall a. IO a -> a
unsafePerformIO (IO (MVar (Map ModuleFile WarningsWithModDate))
 -> MVar (Map ModuleFile WarningsWithModDate))
-> IO (MVar (Map ModuleFile WarningsWithModDate))
-> MVar (Map ModuleFile WarningsWithModDate)
forall a b. (a -> b) -> a -> b
$ Map ModuleFile WarningsWithModDate
-> IO (MVar (Map ModuleFile WarningsWithModDate))
forall a. a -> IO (MVar a)
newMVar Map ModuleFile WarningsWithModDate
forall a. Monoid a => a
mempty
{-# NOINLINE globalState #-}

--------------------------------------------------------------------------------
-- Plugin
--------------------------------------------------------------------------------

-- dynFlagsPlugin is being removed in future GHC. There is instead a way to
-- modify the HscEnv and there is a Logger type on HscEnv that should allow
-- for hooking into messages.
plugin :: Ghc.Plugin
plugin :: Plugin
plugin =
  Plugin
Ghc.defaultPlugin
    { Ghc.tcPlugin           = const $ Just tcPlugin
    , Ghc.parsedResultAction = const resetPinnedWarnsForMod
    , Ghc.driverPlugin       = const (pure . addWarningCapture)
    , Ghc.pluginRecompile    = Ghc.purePlugin
    }

tcPlugin :: Ghc.TcPlugin
tcPlugin :: TcPlugin
tcPlugin =
  Ghc.TcPlugin
    { tcPluginInit :: TcPluginM PluginState
Ghc.tcPluginInit  = TcPluginM PluginState
initTcPlugin
    , tcPluginSolve :: PluginState -> TcPluginSolver
Ghc.tcPluginSolve = \PluginState
pluginState EvBindsVar
_ [Ct]
_ -> PluginState -> [Ct] -> TcPluginM TcPluginResult'
checkWanteds PluginState
pluginState
    , tcPluginStop :: PluginState -> TcPluginM ()
Ghc.tcPluginStop  = TcPluginM () -> PluginState -> TcPluginM ()
forall a b. a -> b -> a
const (TcPluginM () -> PluginState -> TcPluginM ())
-> TcPluginM () -> PluginState -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ () -> TcPluginM ()
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if MIN_VERSION_ghc(9,4,0)
    , tcPluginRewrite :: PluginState -> UniqFM TyCon TcPluginRewriter
Ghc.tcPluginRewrite = PluginState -> UniqFM TyCon TcPluginRewriter
forall a. Monoid a => a
mempty
#endif
    }

data PluginState =
  MkPluginState
    { PluginState -> TyCon
showWarningsClass  :: Ghc.TyCon
    , PluginState -> TyCon
fixWarningsClass   :: Ghc.TyCon
    , PluginState -> TyCon
clearWarningsClass :: Ghc.TyCon
    , PluginState -> IORef Int
counterRef         :: IORef Int
    }

initTcPlugin :: Ghc.TcPluginM PluginState
initTcPlugin :: TcPluginM PluginState
initTcPlugin =
  TyCon -> TyCon -> TyCon -> IORef Int -> PluginState
MkPluginState
    (TyCon -> TyCon -> TyCon -> IORef Int -> PluginState)
-> TcPluginM TyCon
-> TcPluginM (TyCon -> TyCon -> IORef Int -> PluginState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleFile -> TcPluginM TyCon
lookupClass ModuleFile
"ShowWarnings"
    TcPluginM (TyCon -> TyCon -> IORef Int -> PluginState)
-> TcPluginM TyCon -> TcPluginM (TyCon -> IORef Int -> PluginState)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ModuleFile -> TcPluginM TyCon
lookupClass ModuleFile
"FixWarnings"
    TcPluginM (TyCon -> IORef Int -> PluginState)
-> TcPluginM TyCon -> TcPluginM (IORef Int -> PluginState)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ModuleFile -> TcPluginM TyCon
lookupClass ModuleFile
"ClearWarnings"
    TcPluginM (IORef Int -> PluginState)
-> TcPluginM (IORef Int) -> TcPluginM PluginState
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (IORef Int) -> TcPluginM (IORef Int)
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0)

-- | Get a reference to a class from the @ShowWarnings@ module
lookupClass :: String -> Ghc.TcPluginM Ghc.TyCon
lookupClass :: ModuleFile -> TcPluginM TyCon
lookupClass ModuleFile
className = do
  FindResult
result <- ModuleName -> PkgQual -> TcPluginM FindResult
Ghc.findImportedModule
              (ModuleFile -> ModuleName
Ghc.mkModuleName ModuleFile
"ShowWarnings")
#if MIN_VERSION_ghc(9,4,0)
              PkgQual
Ghc.NoPkgQual
#else
              (Just "pinned-warnings")
#endif

  case FindResult
result of
    Ghc.Found ModLocation
_ Module
mod' -> do
      Name
name <- Module -> OccName -> TcPluginM Name
Ghc.lookupOrig Module
mod' (OccName -> TcPluginM Name) -> OccName -> TcPluginM Name
forall a b. (a -> b) -> a -> b
$ ModuleFile -> OccName
Ghc.mkTcOcc ModuleFile
className
      Class -> TyCon
Ghc.classTyCon (Class -> TyCon) -> TcPluginM Class -> TcPluginM TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcPluginM Class
Ghc.tcLookupClass Name
name

    FindResult
_ -> ModuleFile -> TcPluginM TyCon
forall a. HasCallStack => ModuleFile -> a
error ModuleFile
"ShowWarnings module not found"

-- | If any wanted constraints are for 'ShowWarnings', then inject the pinned
-- warnings into GHC.
checkWanteds :: PluginState
             -> [Ghc.Ct]
             -> Ghc.TcPluginM Ghc.TcPluginResult'
checkWanteds :: PluginState -> [Ct] -> TcPluginM TcPluginResult'
checkWanteds PluginState
pluginState
    = ([Maybe (EvTerm, Ct)] -> TcPluginResult')
-> TcPluginM [Maybe (EvTerm, Ct)] -> TcPluginM TcPluginResult'
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(EvTerm, Ct)] -> [Ct] -> TcPluginResult')
-> [Ct] -> [(EvTerm, Ct)] -> TcPluginResult'
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(EvTerm, Ct)] -> [Ct] -> TcPluginResult'
Ghc.TcPluginOk [] ([(EvTerm, Ct)] -> TcPluginResult')
-> ([Maybe (EvTerm, Ct)] -> [(EvTerm, Ct)])
-> [Maybe (EvTerm, Ct)]
-> TcPluginResult'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (EvTerm, Ct)] -> [(EvTerm, Ct)]
forall a. [Maybe a] -> [a]
catMaybes)
    (TcPluginM [Maybe (EvTerm, Ct)] -> TcPluginM TcPluginResult')
-> ([Ct] -> TcPluginM [Maybe (EvTerm, Ct)])
-> [Ct]
-> TcPluginM TcPluginResult'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ct -> TcPluginM (Maybe (EvTerm, Ct)))
-> [Ct] -> TcPluginM [Maybe (EvTerm, Ct)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Ct -> TcPluginM (Maybe (EvTerm, Ct))
go
  where
    go :: Ct -> TcPluginM (Maybe (EvTerm, Ct))
go ct :: Ct
ct@(Ghc.CDictCan' CtEvidence
_ Class
cls [Xi]
_)
      | Class -> TyCon
Ghc.classTyCon Class
cls TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== PluginState -> TyCon
showWarningsClass PluginState
pluginState = do
          Int
counter <- IO Int -> TcPluginM Int
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (IO Int -> TcPluginM Int) -> IO Int -> TcPluginM Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (PluginState -> IORef Int
counterRef PluginState
pluginState)

          -- for some reason warnings only appear if they are added on
          -- particular iterations.
          Bool -> TcPluginM () -> TcPluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
counter Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) TcPluginM ()
addWarningsToContext
          TcPluginM ()
incrementCounter

          Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a b. (a -> b) -> a -> b
$ (EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvExpr -> EvTerm
Ghc.EvExpr EvExpr
Ghc.unitExpr, Ct
ct)

      | Class -> TyCon
Ghc.classTyCon Class
cls TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== PluginState -> TyCon
fixWarningsClass PluginState
pluginState = do
          Int
counter <- IO Int -> TcPluginM Int
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (IO Int -> TcPluginM Int) -> IO Int -> TcPluginM Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (PluginState -> IORef Int
counterRef PluginState
pluginState)

          Bool -> TcPluginM () -> TcPluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
counter Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO IO ()
fixWarnings)
          TcPluginM ()
incrementCounter

          Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a b. (a -> b) -> a -> b
$ (EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvExpr -> EvTerm
Ghc.EvExpr EvExpr
Ghc.unitExpr, Ct
ct)

      | Class -> TyCon
Ghc.classTyCon Class
cls TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== PluginState -> TyCon
clearWarningsClass PluginState
pluginState = do
          Int
counter <- IO Int -> TcPluginM Int
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (IO Int -> TcPluginM Int) -> IO Int -> TcPluginM Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (PluginState -> IORef Int
counterRef PluginState
pluginState)

          Bool -> TcPluginM () -> TcPluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
counter Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO IO ()
clearWarnings)
          TcPluginM ()
incrementCounter

          Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a b. (a -> b) -> a -> b
$ (EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvExpr -> EvTerm
Ghc.EvExpr EvExpr
Ghc.unitExpr, Ct
ct)

    go Ct
_ = Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, Ct)
forall a. Maybe a
Nothing

    incrementCounter :: TcPluginM ()
incrementCounter =
      IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (IO () -> TcPluginM ()) -> IO () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PluginState -> IORef Int
counterRef PluginState
pluginState) Int -> Int
forall a. Enum a => a -> a
succ

-- | Add warnings from the global state back into the GHC context
addWarningsToContext :: Ghc.TcPluginM ()
addWarningsToContext :: TcPluginM ()
addWarningsToContext = do
  TcRef (Messages TcRnMessage)
errsRef <- TcLclEnv -> TcRef (Messages TcRnMessage)
Ghc.tcl_errs (TcLclEnv -> TcRef (Messages TcRnMessage))
-> ((TcGblEnv, TcLclEnv) -> TcLclEnv)
-> (TcGblEnv, TcLclEnv)
-> TcRef (Messages TcRnMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcGblEnv, TcLclEnv) -> TcLclEnv
forall a b. (a, b) -> b
snd ((TcGblEnv, TcLclEnv) -> TcRef (Messages TcRnMessage))
-> TcPluginM (TcGblEnv, TcLclEnv)
-> TcPluginM (TcRef (Messages TcRnMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcPluginM (TcGblEnv, TcLclEnv)
Ghc.getEnvs

  IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO IO ()
pruneDeleted
  Bag (MsgEnvelope DiagnosticMessage)
pinnedWarns <- [MsgEnvelope DiagnosticMessage]
-> Bag (MsgEnvelope DiagnosticMessage)
forall a. [a] -> Bag a
Ghc.listToBag ([MsgEnvelope DiagnosticMessage]
 -> Bag (MsgEnvelope DiagnosticMessage))
-> (Map ModuleFile WarningsWithModDate
    -> [MsgEnvelope DiagnosticMessage])
-> Map ModuleFile WarningsWithModDate
-> Bag (MsgEnvelope DiagnosticMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Warning -> MsgEnvelope DiagnosticMessage)
-> [Warning] -> [MsgEnvelope DiagnosticMessage]
forall a b. (a -> b) -> [a] -> [b]
map Warning -> MsgEnvelope DiagnosticMessage
unWarning
               ([Warning] -> [MsgEnvelope DiagnosticMessage])
-> (Map ModuleFile WarningsWithModDate -> [Warning])
-> Map ModuleFile WarningsWithModDate
-> [MsgEnvelope DiagnosticMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WarningsWithModDate -> [Warning])
-> Map ModuleFile WarningsWithModDate -> [Warning]
forall m a. Monoid m => (a -> m) -> Map ModuleFile a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Set Warning -> [Warning])
-> MonoidMap SrcSpanKey (Set Warning) -> [Warning]
forall m a. Monoid m => (a -> m) -> MonoidMap SrcSpanKey a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Set Warning -> [Warning]
forall a. Set a -> [a]
S.toList (MonoidMap SrcSpanKey (Set Warning) -> [Warning])
-> (WarningsWithModDate -> MonoidMap SrcSpanKey (Set Warning))
-> WarningsWithModDate
-> [Warning]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningsWithModDate -> MonoidMap SrcSpanKey (Set Warning)
warningsMap)
             (Map ModuleFile WarningsWithModDate
 -> Bag (MsgEnvelope DiagnosticMessage))
-> TcPluginM (Map ModuleFile WarningsWithModDate)
-> TcPluginM (Bag (MsgEnvelope DiagnosticMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map ModuleFile WarningsWithModDate)
-> TcPluginM (Map ModuleFile WarningsWithModDate)
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (MVar (Map ModuleFile WarningsWithModDate)
-> IO (Map ModuleFile WarningsWithModDate)
forall a. MVar a -> IO a
readMVar MVar (Map ModuleFile WarningsWithModDate)
globalState)

  IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Ghc.tcPluginIO (IO () -> TcPluginM ())
-> ((Messages TcRnMessage -> (Messages TcRnMessage, ())) -> IO ())
-> (Messages TcRnMessage -> (Messages TcRnMessage, ()))
-> TcPluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRef (Messages TcRnMessage)
-> (Messages TcRnMessage -> (Messages TcRnMessage, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' TcRef (Messages TcRnMessage)
errsRef
#if MIN_VERSION_ghc(9,6,0)
    ((Messages TcRnMessage -> (Messages TcRnMessage, ()))
 -> TcPluginM ())
-> (Messages TcRnMessage -> (Messages TcRnMessage, ()))
-> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ \Messages TcRnMessage
messages ->
        (Bag (MsgEnvelope TcRnMessage) -> Messages TcRnMessage
forall e. Bag (MsgEnvelope e) -> Messages e
Ghc.mkMessages (((MsgEnvelope DiagnosticMessage -> MsgEnvelope TcRnMessage)
-> Bag (MsgEnvelope DiagnosticMessage)
-> Bag (MsgEnvelope TcRnMessage)
forall a b. (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MsgEnvelope DiagnosticMessage -> MsgEnvelope TcRnMessage)
 -> Bag (MsgEnvelope DiagnosticMessage)
 -> Bag (MsgEnvelope TcRnMessage))
-> ((DiagnosticMessage -> TcRnMessage)
    -> MsgEnvelope DiagnosticMessage -> MsgEnvelope TcRnMessage)
-> (DiagnosticMessage -> TcRnMessage)
-> Bag (MsgEnvelope DiagnosticMessage)
-> Bag (MsgEnvelope TcRnMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagnosticMessage -> TcRnMessage)
-> MsgEnvelope DiagnosticMessage -> MsgEnvelope TcRnMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
Ghc.mkTcRnUnknownMessage Bag (MsgEnvelope DiagnosticMessage)
pinnedWarns)
          Messages TcRnMessage
-> Messages TcRnMessage -> Messages TcRnMessage
forall e. Messages e -> Messages e -> Messages e
`Ghc.unionMessages` Messages TcRnMessage
messages, ())
#elif MIN_VERSION_ghc(9,4,0)
    $ \messages ->
        (Ghc.mkMessages ((fmap . fmap) Ghc.TcRnUnknownMessage pinnedWarns)
          `Ghc.unionMessages` messages, ())
#endif

-- | Remove warnings for modules that no longer exist
pruneDeleted :: IO ()
pruneDeleted :: IO ()
pruneDeleted = MVar (Map ModuleFile WarningsWithModDate)
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map ModuleFile WarningsWithModDate)
globalState ((Map ModuleFile WarningsWithModDate
  -> IO (Map ModuleFile WarningsWithModDate))
 -> IO ())
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map ModuleFile WarningsWithModDate
warns -> do
  -- remove keys that have no warnings
  let warns' :: Map ModuleFile WarningsWithModDate
warns' = (WarningsWithModDate -> Bool)
-> Map ModuleFile WarningsWithModDate
-> Map ModuleFile WarningsWithModDate
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (WarningsWithModDate -> Bool) -> WarningsWithModDate -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonoidMap SrcSpanKey (Set Warning) -> Bool
forall a. MonoidMap SrcSpanKey a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (MonoidMap SrcSpanKey (Set Warning) -> Bool)
-> (WarningsWithModDate -> MonoidMap SrcSpanKey (Set Warning))
-> WarningsWithModDate
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningsWithModDate -> MonoidMap SrcSpanKey (Set Warning)
warningsMap) Map ModuleFile WarningsWithModDate
warns
      mods :: [ModuleFile]
mods = Map ModuleFile WarningsWithModDate -> [ModuleFile]
forall k a. Map k a -> [k]
M.keys Map ModuleFile WarningsWithModDate
warns'

  [ModuleFile]
deletedMods <-
    (ModuleFile -> IO Bool) -> [ModuleFile] -> IO [ModuleFile]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool)
-> (ModuleFile -> IO Bool) -> ModuleFile -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleFile -> IO Bool
Dir.doesFileExist)
            [ModuleFile]
mods

  Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleFile WarningsWithModDate
 -> IO (Map ModuleFile WarningsWithModDate))
-> Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall a b. (a -> b) -> a -> b
$ (Map ModuleFile WarningsWithModDate
 -> ModuleFile -> Map ModuleFile WarningsWithModDate)
-> Map ModuleFile WarningsWithModDate
-> [ModuleFile]
-> Map ModuleFile WarningsWithModDate
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((ModuleFile
 -> Map ModuleFile WarningsWithModDate
 -> Map ModuleFile WarningsWithModDate)
-> Map ModuleFile WarningsWithModDate
-> ModuleFile
-> Map ModuleFile WarningsWithModDate
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleFile
-> Map ModuleFile WarningsWithModDate
-> Map ModuleFile WarningsWithModDate
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map ModuleFile WarningsWithModDate
warns' [ModuleFile]
deletedMods

-- | Removes currently pinned warnings for a module and updates the timestamp.
-- This occurs before any new warnings are captured for the module.
resetPinnedWarnsForMod
  :: Ghc.ModSummary
#if MIN_VERSION_ghc(9,4,0)
  -> Ghc.ParsedResult
  -> Ghc.Hsc Ghc.ParsedResult
#else
  -> Ghc.HsParsedModule
  -> Ghc.Hsc Ghc.HsParsedModule
#endif
resetPinnedWarnsForMod :: ModSummary -> ParsedResult -> Hsc ParsedResult
resetPinnedWarnsForMod ModSummary
modSummary ParsedResult
parsedModule = do
  let modFile :: ModuleFile
modFile = ModuleFile -> ModuleFile
forall a. IsString a => ModuleFile -> a
fromString (ModuleFile -> ModuleFile) -> ModuleFile -> ModuleFile
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleFile
Ghc.ms_hspp_file ModSummary
modSummary

  IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ())
-> ((Map ModuleFile WarningsWithModDate
     -> IO (Map ModuleFile WarningsWithModDate))
    -> IO ())
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Map ModuleFile WarningsWithModDate)
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map ModuleFile WarningsWithModDate)
globalState
    ((Map ModuleFile WarningsWithModDate
  -> IO (Map ModuleFile WarningsWithModDate))
 -> Hsc ())
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleFile WarningsWithModDate
 -> IO (Map ModuleFile WarningsWithModDate))
-> (Map ModuleFile WarningsWithModDate
    -> Map ModuleFile WarningsWithModDate)
-> Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleFile
-> Map ModuleFile WarningsWithModDate
-> Map ModuleFile WarningsWithModDate
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ModuleFile
modFile

  ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedResult
parsedModule

-- | Taps into the log action to capture the warnings that GHC emits.
addWarningCapture :: Ghc.HscEnv -> Ghc.HscEnv
addWarningCapture :: HscEnv -> HscEnv
addWarningCapture HscEnv
hscEnv =
  HscEnv
hscEnv
    { Ghc.hsc_logger = Ghc.pushLogHook warningsHook (Ghc.hsc_logger hscEnv)
    }
  where
    warningsHook :: Ghc.LogAction -> Ghc.LogAction
    warningsHook :: LogAction -> LogAction
warningsHook LogAction
logAction LogFlags
dynFlags MessageClass
messageClass SrcSpan
srcSpan SDoc
sdoc = do
      case MessageClass
messageClass of
#if MIN_VERSION_ghc(9,6,0)
        Ghc.MCDiagnostic Severity
Ghc.SevWarning DiagnosticReason
_ Maybe DiagnosticCode
_
#else
        Ghc.MCDiagnostic Ghc.SevWarning _
#endif
          | Ghc.RealSrcLoc RealSrcLoc
start Maybe BufPos
_ <- SrcSpan -> SrcLoc
Ghc.srcSpanStart SrcSpan
srcSpan
          , Ghc.RealSrcLoc RealSrcLoc
end Maybe BufPos
_ <- SrcSpan -> SrcLoc
Ghc.srcSpanEnd SrcSpan
srcSpan
          , Just FastString
modFile <- SrcSpan -> Maybe FastString
Ghc.srcSpanFileName_maybe SrcSpan
srcSpan
          -> do
            let diag :: DiagnosticMessage
diag =
                  Ghc.DiagnosticMessage
                    { diagMessage :: DecoratedSDoc
Ghc.diagMessage = SDoc -> DecoratedSDoc
Ghc.mkSimpleDecorated SDoc
sdoc
                    , diagReason :: DiagnosticReason
Ghc.diagReason = DiagnosticReason
Ghc.WarningWithoutFlag
                    , diagHints :: [GhcHint]
Ghc.diagHints = []
                    }
                diagOpts :: DiagOpts
diagOpts = DynFlags -> DiagOpts
Ghc.initDiagOpts (DynFlags -> DiagOpts) -> DynFlags -> DiagOpts
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
Ghc.hsc_dflags HscEnv
hscEnv
                warn :: Warning
warn = MsgEnvelope DiagnosticMessage -> Warning
Warning (MsgEnvelope DiagnosticMessage -> Warning)
-> MsgEnvelope DiagnosticMessage -> Warning
forall a b. (a -> b) -> a -> b
$
                  DiagOpts
-> SrcSpan
-> NamePprCtx
-> DiagnosticMessage
-> MsgEnvelope DiagnosticMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
Ghc.mkMsgEnvelope DiagOpts
diagOpts SrcSpan
srcSpan NamePprCtx
Ghc.neverQualify DiagnosticMessage
diag
            RealSrcLoc -> RealSrcLoc -> FastString -> Warning -> IO ()
addWarningToGlobalState RealSrcLoc
start RealSrcLoc
end FastString
modFile Warning
warn
        MessageClass
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LogAction
logAction LogFlags
dynFlags MessageClass
messageClass SrcSpan
srcSpan SDoc
sdoc

-- | Adds a warning to the global state variable
addWarningToGlobalState
  :: Ghc.RealSrcLoc -- ^ start location
  -> Ghc.RealSrcLoc -- ^ end location
  -> Ghc.FastString -- ^ module name
  -> Warning
  -> IO ()
addWarningToGlobalState :: RealSrcLoc -> RealSrcLoc -> FastString -> Warning -> IO ()
addWarningToGlobalState RealSrcLoc
start RealSrcLoc
end FastString
modFile Warning
warn = do
  let wrappedWarn :: Map SrcSpanKey (Set Warning)
wrappedWarn = SrcSpanKey -> Set Warning -> Map SrcSpanKey (Set Warning)
forall k a. k -> a -> Map k a
M.singleton (RealSrcLoc
start, RealSrcLoc
end)
                  (Set Warning -> Map SrcSpanKey (Set Warning))
-> Set Warning -> Map SrcSpanKey (Set Warning)
forall a b. (a -> b) -> a -> b
$ Warning -> Set Warning
forall a. a -> Set a
S.singleton Warning
warn
      file :: ModuleFile
file = FastString -> ModuleFile
Ghc.unpackFS FastString
modFile
  Bool
exists <- ModuleFile -> IO Bool
Dir.doesFileExist ModuleFile
file
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
fileModifiedAt <- ModuleFile -> IO UTCTime
Dir.getModificationTime ModuleFile
file
    MVar (Map ModuleFile WarningsWithModDate)
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map ModuleFile WarningsWithModDate)
globalState
      ((Map ModuleFile WarningsWithModDate
  -> IO (Map ModuleFile WarningsWithModDate))
 -> IO ())
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Map ModuleFile WarningsWithModDate
 -> IO (Map ModuleFile WarningsWithModDate))
-> (Map ModuleFile WarningsWithModDate
    -> Map ModuleFile WarningsWithModDate)
-> Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WarningsWithModDate -> WarningsWithModDate -> WarningsWithModDate)
-> ModuleFile
-> WarningsWithModDate
-> Map ModuleFile WarningsWithModDate
-> Map ModuleFile WarningsWithModDate
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith WarningsWithModDate -> WarningsWithModDate -> WarningsWithModDate
forall a. Semigroup a => a -> a -> a
(<>) ModuleFile
file
          MkWarningsWithModDate
            { lastUpdated :: UTCTime
lastUpdated = UTCTime
fileModifiedAt
            , warningsMap :: MonoidMap SrcSpanKey (Set Warning)
warningsMap = Map SrcSpanKey (Set Warning) -> MonoidMap SrcSpanKey (Set Warning)
forall k a. Map k a -> MonoidMap k a
MonoidMap Map SrcSpanKey (Set Warning)
wrappedWarn
            }

fixWarnings :: IO ()
fixWarnings :: IO ()
fixWarnings = do
  IO ()
pruneDeleted

  MVar (Map ModuleFile WarningsWithModDate)
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map ModuleFile WarningsWithModDate)
globalState ((Map ModuleFile WarningsWithModDate
  -> IO (Map ModuleFile WarningsWithModDate))
 -> IO ())
-> (Map ModuleFile WarningsWithModDate
    -> IO (Map ModuleFile WarningsWithModDate))
-> IO ()
forall a b. (a -> b) -> a -> b
$
    (ModuleFile -> WarningsWithModDate -> IO WarningsWithModDate)
-> Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey ModuleFile -> WarningsWithModDate -> IO WarningsWithModDate
FW.fixWarning

clearWarnings :: IO ()
clearWarnings :: IO ()
clearWarnings =
  IO (Map ModuleFile WarningsWithModDate) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Map ModuleFile WarningsWithModDate) -> IO ())
-> IO (Map ModuleFile WarningsWithModDate) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Map ModuleFile WarningsWithModDate)
-> Map ModuleFile WarningsWithModDate
-> IO (Map ModuleFile WarningsWithModDate)
forall a. MVar a -> a -> IO a
swapMVar MVar (Map ModuleFile WarningsWithModDate)
globalState Map ModuleFile WarningsWithModDate
forall k a. Map k a
M.empty