{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
module GhciQuickfix
  ( plugin
  , pluginOffByDefault
  ) where

import           Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import           Control.Concurrent.STM.TVar
import           Control.Exception
import qualified Control.Foldl as F
import           Control.Monad
import           Control.Monad.STM
import qualified Data.Char as Char
import           Data.Either (partitionEithers)
import           Data.Foldable
import           Data.IORef
import           Data.List (stripPrefix)
import           Data.Maybe
import           Data.Monoid (First(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import           Data.Traversable
import qualified DeferredFolds.UnfoldlM as DF
import qualified StmContainers.Map as SM
import qualified System.Directory as Dir
import qualified System.Environment as Env

import qualified GhciQuickfix.GhcFacade as Ghc

type ErrMap = SM.Map FilePath [T.Text]

plugin :: Ghc.Plugin
plugin :: Plugin
plugin = Plugin
Ghc.defaultPlugin
  { Ghc.driverPlugin = modifyHscEnv False
  , Ghc.pluginRecompile = mempty
  }

-- | For use with repl-alliance, where this plugin should be off by default
pluginOffByDefault :: Ghc.Plugin
pluginOffByDefault :: Plugin
pluginOffByDefault = Plugin
plugin
  { Ghc.driverPlugin = modifyHscEnv True }

-- | Background process that writes the quickfix file when errors change. Adds a
-- delay to mitigate excessive IO.
writeQuickfixLoop :: Maybe FilePath -> ErrMap -> TVar Bool -> IO ()
writeQuickfixLoop :: Maybe FilePath -> ErrMap -> TVar Bool -> IO ()
writeQuickfixLoop Maybe FilePath
mErrFilePath ErrMap
errMap TVar Bool
updated = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [(FilePath, [Text])]
msgs <- STM [(FilePath, [Text])] -> IO [(FilePath, [Text])]
forall a. STM a -> IO a
atomically (STM [(FilePath, [Text])] -> IO [(FilePath, [Text])])
-> STM [(FilePath, [Text])] -> IO [(FilePath, [Text])]
forall a b. (a -> b) -> a -> b
$ do
      Bool -> STM ()
check (Bool -> STM ()) -> STM Bool -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
updated
      TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
updated Bool
False
      FoldM STM (FilePath, [Text]) [(FilePath, [Text])]
-> UnfoldlM STM (FilePath, [Text]) -> STM [(FilePath, [Text])]
forall (m :: * -> *) input output.
Monad m =>
FoldM m input output -> UnfoldlM m input -> m output
DF.foldM (Fold (FilePath, [Text]) [(FilePath, [Text])]
-> FoldM STM (FilePath, [Text]) [(FilePath, [Text])]
forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
F.generalize Fold (FilePath, [Text]) [(FilePath, [Text])]
forall a. Fold a [a]
F.list) (ErrMap -> UnfoldlM STM (FilePath, [Text])
forall key value. Map key value -> UnfoldlM STM (key, value)
SM.unfoldlM ErrMap
errMap)
    [Text]
prunedMsgs <- [(FilePath, [Text])] -> ErrMap -> IO [Text]
pruneDeletedFiles [(FilePath, [Text])]
msgs ErrMap
errMap
    FilePath -> Text -> IO ()
TIO.writeFile (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"errors.err" Maybe FilePath
mErrFilePath) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
prunedMsgs
    Int -> IO ()
threadDelay Int
200_000 -- 200ms

parseFilePathModifier :: [Ghc.CommandLineOption] -> IO (Either String [T.Text -> T.Text])
parseFilePathModifier :: [FilePath] -> IO (Either FilePath [Text -> Text])
parseFilePathModifier [FilePath]
opts = do
  Maybe (Either FilePath (Text -> Text))
envMod <- IO (Maybe (Either FilePath (Text -> Text)))
getEnvModifier
  Either FilePath [Text -> Text]
-> IO (Either FilePath [Text -> Text])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath [Text -> Text]
 -> IO (Either FilePath [Text -> Text]))
-> Either FilePath [Text -> Text]
-> IO (Either FilePath [Text -> Text])
forall a b. (a -> b) -> a -> b
$ case [Either FilePath (Text -> Text)] -> ([FilePath], [Text -> Text])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((FilePath -> Maybe (Either FilePath (Text -> Text)))
-> [FilePath] -> [Either FilePath (Text -> Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe (Either FilePath (Text -> Text))
getModifier [FilePath]
opts [Either FilePath (Text -> Text)]
-> [Either FilePath (Text -> Text)]
-> [Either FilePath (Text -> Text)]
forall a. [a] -> [a] -> [a]
++ Maybe (Either FilePath (Text -> Text))
-> [Either FilePath (Text -> Text)]
forall a. Maybe a -> [a]
maybeToList Maybe (Either FilePath (Text -> Text))
envMod) of
    ([], [Text -> Text]
modifiers) -> [Text -> Text] -> Either FilePath [Text -> Text]
forall a b. b -> Either a b
Right [Text -> Text]
modifiers
    ([FilePath]
errs, [Text -> Text]
_) -> FilePath -> Either FilePath [Text -> Text]
forall a b. a -> Either a b
Left ([FilePath] -> FilePath
unlines [FilePath]
errs)
  where
  parseReplacement :: String -> String -> Either String (T.Text -> T.Text)
  parseReplacement :: FilePath -> FilePath -> Either FilePath (Text -> Text)
parseReplacement FilePath
source FilePath
pat =
    case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (FilePath -> Text
T.pack FilePath
pat) of
      [Text
needle, Text
replace] -> (Text -> Text) -> Either FilePath (Text -> Text)
forall a b. b -> Either a b
Right ((Text -> Text) -> Either FilePath (Text -> Text))
-> (Text -> Text) -> Either FilePath (Text -> Text)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
needle Text
replace
      [Text]
_ -> FilePath -> Either FilePath (Text -> Text)
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (Text -> Text))
-> FilePath -> Either FilePath (Text -> Text)
forall a b. (a -> b) -> a -> b
$ FilePath
"Malformed " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
source FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": expected format 'needle:replace', got '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'"
  getEnvModifier :: IO (Maybe (Either FilePath (Text -> Text)))
getEnvModifier = do
    Maybe FilePath
mPat <- FilePath -> IO (Maybe FilePath)
Env.lookupEnv FilePath
"GHCI_QUICKFIX_PATH_REPLACE"
    Maybe (Either FilePath (Text -> Text))
-> IO (Maybe (Either FilePath (Text -> Text)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either FilePath (Text -> Text))
 -> IO (Maybe (Either FilePath (Text -> Text))))
-> Maybe (Either FilePath (Text -> Text))
-> IO (Maybe (Either FilePath (Text -> Text)))
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Either FilePath (Text -> Text)
parseReplacement FilePath
"GHCI_QUICKFIX_PATH_REPLACE environment variable" (FilePath -> Either FilePath (Text -> Text))
-> Maybe FilePath -> Maybe (Either FilePath (Text -> Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
mPat
  getModifier :: FilePath -> Maybe (Either FilePath (Text -> Text))
getModifier FilePath
opt = do
    FilePath
pat <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"--quickfix-path-replace=" FilePath
opt
    Either FilePath (Text -> Text)
-> Maybe (Either FilePath (Text -> Text))
forall a. a -> Maybe a
Just (Either FilePath (Text -> Text)
 -> Maybe (Either FilePath (Text -> Text)))
-> Either FilePath (Text -> Text)
-> Maybe (Either FilePath (Text -> Text))
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Either FilePath (Text -> Text)
parseReplacement FilePath
"--quickfix-path-replace argument" FilePath
pat

parseQuickfixFilePath :: [Ghc.CommandLineOption] -> IO (Maybe FilePath)
parseQuickfixFilePath :: [FilePath] -> IO (Maybe FilePath)
parseQuickfixFilePath [FilePath]
opts = do
  Maybe FilePath
envPath <- FilePath -> IO (Maybe FilePath)
Env.lookupEnv FilePath
"GHCI_QUICKFIX_FILE"
  Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ First FilePath -> Maybe FilePath
forall a. First a -> Maybe a
getFirst (First FilePath -> Maybe FilePath)
-> First FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> First FilePath) -> [FilePath] -> First FilePath
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe FilePath -> First FilePath
forall a. Maybe a -> First a
First (Maybe FilePath -> First FilePath)
-> (FilePath -> Maybe FilePath) -> FilePath -> First FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"--quickfix-file=") [FilePath]
opts First FilePath -> First FilePath -> First FilePath
forall a. Semigroup a => a -> a -> a
<> Maybe FilePath -> First FilePath
forall a. Maybe a -> First a
First Maybe FilePath
envPath

parseIncludeParserErrors :: [Ghc.CommandLineOption] -> IO Bool
parseIncludeParserErrors :: [FilePath] -> IO Bool
parseIncludeParserErrors [FilePath]
opts = do
  Bool
envEnabled <- (Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"true") (Maybe FilePath -> Bool)
-> (Maybe FilePath -> Maybe FilePath) -> Maybe FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower)
    (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
Env.lookupEnv FilePath
"GHCI_QUICKFIX_INCLUDE_PARSER_ERRORS"
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
"--quickfix-include-parser-errors" [FilePath]
opts Bool -> Bool -> Bool
|| Bool
envEnabled

explicitlyEnabled :: [Ghc.CommandLineOption] -> IO Bool
explicitlyEnabled :: [FilePath] -> IO Bool
explicitlyEnabled [FilePath]
opts = do
  Bool
envEnabled <- (Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"true") (Maybe FilePath -> Bool)
-> (Maybe FilePath -> Maybe FilePath) -> Maybe FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower)
    (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
Env.lookupEnv FilePath
"GHCI_QUICKFIX_ENABLED"
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
"--quickfix" [FilePath]
opts Bool -> Bool -> Bool
|| Bool
envEnabled

modifyHscEnv :: Bool -> [Ghc.CommandLineOption] -> Ghc.HscEnv -> IO Ghc.HscEnv
modifyHscEnv :: Bool -> [FilePath] -> HscEnv -> IO HscEnv
modifyHscEnv Bool
isOffByDefault [FilePath]
opts HscEnv
hscEnv = do
  Bool
enabled <- [FilePath] -> IO Bool
explicitlyEnabled [FilePath]
opts
  if Bool -> Bool
not Bool
isOffByDefault Bool -> Bool -> Bool
|| Bool
enabled then do
    [FilePath] -> IO (Either FilePath [Text -> Text])
parseFilePathModifier [FilePath]
opts IO (Either FilePath [Text -> Text])
-> (Either FilePath [Text -> Text] -> IO HscEnv) -> IO HscEnv
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left FilePath
err -> FilePath -> IO HscEnv
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err
      Right [Text -> Text]
filePathMods -> do
        ErrMap
errMap <- IO ErrMap
forall key value. IO (Map key value)
SM.newIO
        TVar Bool
errsUpdated <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
        Maybe FilePath
quickfixFilePath <- [FilePath] -> IO (Maybe FilePath)
parseQuickfixFilePath [FilePath]
opts
        IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ())
-> (IO () -> IO (Async ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> ErrMap -> TVar Bool -> IO ()
writeQuickfixLoop Maybe FilePath
quickfixFilePath ErrMap
errMap TVar Bool
errsUpdated
        Bool
includeParserErrors <- [FilePath] -> IO Bool
parseIncludeParserErrors [FilePath]
opts
        HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HscEnv
hscEnv { Ghc.hsc_hooks = modifyHooks includeParserErrors filePathMods (Ghc.hsc_hooks hscEnv) errMap errsUpdated }
  else
    HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HscEnv
hscEnv
  where
    modifyHooks :: Bool -> [Text -> Text] -> Hooks -> ErrMap -> TVar Bool -> Hooks
modifyHooks Bool
includeParserErrors [Text -> Text]
filePathMods Hooks
hooks (ErrMap
errMap :: ErrMap) (TVar Bool
errsUpdated :: TVar Bool) =
      let runPhaseOrExistingHook :: Ghc.TPhase res -> IO res
          runPhaseOrExistingHook :: forall res. TPhase res -> IO res
runPhaseOrExistingHook = (TPhase res -> IO res)
-> (PhaseHook -> TPhase res -> IO res)
-> Maybe PhaseHook
-> TPhase res
-> IO res
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TPhase res -> IO res
forall res. TPhase res -> IO res
Ghc.runPhase (\(Ghc.PhaseHook forall res. TPhase res -> IO res
h) -> TPhase res -> IO res
forall res. TPhase res -> IO res
h)
            (Maybe PhaseHook -> TPhase res -> IO res)
-> Maybe PhaseHook -> TPhase res -> IO res
forall a b. (a -> b) -> a -> b
$ Hooks -> Maybe PhaseHook
Ghc.runPhaseHook Hooks
hooks
          phaseHook :: Ghc.PhaseHook
          phaseHook :: PhaseHook
phaseHook = (forall res. TPhase res -> IO res) -> PhaseHook
Ghc.PhaseHook ((forall res. TPhase res -> IO res) -> PhaseHook)
-> (forall res. TPhase res -> IO res) -> PhaseHook
forall a b. (a -> b) -> a -> b
$ \TPhase a
phase -> do
            let tcWarnings :: Ghc.Messages Ghc.GhcMessage
                tcWarnings :: Messages GhcMessage
tcWarnings = case TPhase a
phase of
                  Ghc.T_HscPostTc HscEnv
_ ModSummary
_ FrontendResult
_ Messages GhcMessage
msgs Maybe Fingerprint
_ -> Messages GhcMessage
msgs
                  TPhase a
_ -> Messages GhcMessage
forall a. Monoid a => a
mempty
            IORef (Messages GhcMessage)
dsWarnVar <- Messages GhcMessage -> IO (IORef (Messages GhcMessage))
forall a. a -> IO (IORef a)
newIORef Messages GhcMessage
forall a. Monoid a => a
mempty
            IO a -> IO (Either SourceError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (TPhase a -> IO a
forall res. TPhase res -> IO res
runPhaseOrExistingHook (TPhase a -> IO a) -> TPhase a -> IO a
forall a b. (a -> b) -> a -> b
$ (LogAction -> LogAction) -> TPhase a -> TPhase a
forall res. (LogAction -> LogAction) -> TPhase res -> TPhase res
addDsLogHook (IORef (Messages GhcMessage) -> HscEnv -> LogAction -> LogAction
logHookHack IORef (Messages GhcMessage)
dsWarnVar HscEnv
hscEnv) TPhase a
phase) IO (Either SourceError a) -> (Either SourceError a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left err :: SourceError
err@(Ghc.SourceError Messages GhcMessage
msgs) -> do
                Bool
-> [Text -> Text]
-> ErrMap
-> TVar Bool
-> Messages GhcMessage
-> IO ()
handleMessages Bool
includeParserErrors [Text -> Text]
filePathMods ErrMap
errMap TVar Bool
errsUpdated Messages GhcMessage
msgs
                SourceError -> IO a
forall a e. Exception e => e -> a
throw SourceError
err
              Right a
res -> do
                Messages GhcMessage
dsWarns <- IORef (Messages GhcMessage) -> IO (Messages GhcMessage)
forall a. IORef a -> IO a
readIORef IORef (Messages GhcMessage)
dsWarnVar
                case TPhase a
phase of
                  Ghc.T_HscPostTc HscEnv
_ ModSummary
modSummary FrontendResult
_ Messages GhcMessage
_ Maybe Fingerprint
_ ->
                    if Messages GhcMessage -> Bool
forall e. Messages e -> Bool
Ghc.isEmptyMessages Messages GhcMessage
dsWarns
                    then STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      -- Module compiled without errors or warnings so delete map entry if exists
                      let modFile :: FilePath
modFile = ModSummary -> FilePath
Ghc.ms_hspp_file ModSummary
modSummary
                      FilePath -> ErrMap -> STM (Maybe [Text])
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
SM.lookup FilePath
modFile ErrMap
errMap STM (Maybe [Text]) -> (Maybe [Text] -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Maybe [Text]
Nothing -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        Just [Text]
_ -> do
                          FilePath -> ErrMap -> STM ()
forall key value. Hashable key => key -> Map key value -> STM ()
SM.delete (ModSummary -> FilePath
Ghc.ms_hspp_file ModSummary
modSummary) ErrMap
errMap
                          TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
errsUpdated Bool
True
                    else Bool
-> [Text -> Text]
-> ErrMap
-> TVar Bool
-> Messages GhcMessage
-> IO ()
handleMessages Bool
includeParserErrors [Text -> Text]
filePathMods ErrMap
errMap TVar Bool
errsUpdated (Messages GhcMessage -> IO ()) -> Messages GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$
                      if Messages GhcMessage -> Int
forall a. Messages a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Messages GhcMessage
tcWarnings Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Messages GhcMessage -> Int
forall a. Messages a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Messages GhcMessage
dsWarns
                      then Messages GhcMessage
tcWarnings -- has preferred formatting
                      else Messages GhcMessage
dsWarns
                  TPhase a
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
       in Hooks
hooks
            { Ghc.runPhaseHook = Just phaseHook }

addDsLogHook :: (Ghc.LogAction -> Ghc.LogAction) -> Ghc.TPhase res -> Ghc.TPhase res
addDsLogHook :: forall res. (LogAction -> LogAction) -> TPhase res -> TPhase res
addDsLogHook LogAction -> LogAction
logHook = \case
  Ghc.T_HscPostTc HscEnv
hscEnv ModSummary
a FrontendResult
b Messages GhcMessage
c Maybe Fingerprint
d ->
    HscEnv
-> ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> TPhase HscBackendAction
Ghc.T_HscPostTc (HscEnv -> HscEnv
addHook HscEnv
hscEnv) ModSummary
a FrontendResult
b Messages GhcMessage
c Maybe Fingerprint
d
  TPhase res
x -> TPhase res
x
  where
    addHook :: HscEnv -> HscEnv
addHook HscEnv
hscEnv = HscEnv
hscEnv { Ghc.hsc_logger = Ghc.pushLogHook logHook $ Ghc.hsc_logger hscEnv }

-- | Get a textual representation of the diagnostic in GCC format
formatDiagnostic :: [T.Text -> T.Text] -> Ghc.MsgEnvelope Ghc.GhcMessage -> Maybe T.Text
formatDiagnostic :: [Text -> Text] -> MsgEnvelope GhcMessage -> Maybe Text
formatDiagnostic [Text -> Text]
filePathMods MsgEnvelope GhcMessage
m = do
  Text
severity <- case MsgEnvelope GhcMessage -> Severity
forall e. MsgEnvelope e -> Severity
Ghc.errMsgSeverity MsgEnvelope GhcMessage
m of
    Severity
Ghc.SevIgnore -> Maybe Text
forall a. Maybe a
Nothing
    -- ^ Ignore this message, for example in case of suppression of warnings
    -- users don't want to see.
    Severity
Ghc.SevWarning -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"warning"
    Severity
Ghc.SevError -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"error"
  RealSrcLoc
startLoc <- RealSrcSpan -> RealSrcLoc
Ghc.realSrcSpanStart (RealSrcSpan -> RealSrcLoc)
-> Maybe RealSrcSpan -> Maybe RealSrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
Ghc.srcSpanToRealSrcSpan (MsgEnvelope GhcMessage -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
Ghc.errMsgSpan MsgEnvelope GhcMessage
m)
  let diag :: GhcMessage
diag = MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
Ghc.errMsgDiagnostic MsgEnvelope GhcMessage
m
      opts :: GhcMessageOpts
opts = (forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
Ghc.defaultDiagnosticOpts @Ghc.GhcMessage)
        { Ghc.tcMessageOpts = (Ghc.defaultDiagnosticOpts @Ghc.TcRnMessage)
          { Ghc.tcOptsShowContext = False -- Omit all the additional stuff
          }
        }
      ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext
        { Ghc.sdocStyle = Ghc.mkErrStyle (Ghc.errMsgContext m)
        , Ghc.sdocCanUseUnicode = True
        }

      file :: Text
file = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (FastString -> ByteString) -> FastString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
Ghc.bytesFS (FastString -> Text) -> FastString -> Text
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> FastString
Ghc.srcLocFile RealSrcLoc
startLoc
      line :: Int
line = RealSrcLoc -> Int
Ghc.srcLocLine RealSrcLoc
startLoc
      col :: Int
col = RealSrcLoc -> Int
Ghc.srcLocCol RealSrcLoc
startLoc
      truncateMsg :: Text -> Text
truncateMsg Text
txt =
        let truncated :: Text
truncated = Int -> Text -> Text
T.take Int
200 Text
txt
        in if Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
200 then Text
truncated Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…" else Text
truncated
      msg :: Text
msg = Text -> Text
truncateMsg (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
" • "
        ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords ([Text] -> Text) -> (SDoc -> [Text]) -> SDoc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> [Text]) -> (SDoc -> Text) -> SDoc -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
        (FilePath -> Text) -> (SDoc -> FilePath) -> SDoc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> FilePath
Ghc.renderWithContext SDocContext
ctx
        (SDoc -> Text) -> [SDoc] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SDoc -> Bool) -> [SDoc] -> [SDoc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> Bool
Ghc.isEmpty SDocContext
ctx) (DecoratedSDoc -> [SDoc]
Ghc.unDecorated (DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
Ghc.diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
opts GhcMessage
diag))

  -- filename:line:column: error: message
  Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> (Text -> Text) -> Text) -> Text -> [Text -> Text] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Text -> Text) -> Text -> Text) -> Text -> (Text -> Text) -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
($)) Text
file [Text -> Text]
filePathMods
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
line) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
col) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
severity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

-- | Update state given all diagnostics for a module
handleMessages :: Bool -> [T.Text -> T.Text] -> ErrMap -> TVar Bool -> Ghc.Messages Ghc.GhcMessage -> IO ()
handleMessages :: Bool
-> [Text -> Text]
-> ErrMap
-> TVar Bool
-> Messages GhcMessage
-> IO ()
handleMessages Bool
includeParserErrors [Text -> Text]
filePathMods ErrMap
errMap TVar Bool
errsUpdated Messages GhcMessage
messages = do
  let envelopes :: Bag (MsgEnvelope GhcMessage)
envelopes = Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Ghc.getMessages Messages GhcMessage
messages
      isParseError :: GhcMessage -> Bool
isParseError = \case
        Ghc.GhcPsMessage{} -> Bool
True
        GhcMessage
_ -> Bool
False
      -- Filter out parse errors unless explicitly included
      errs :: [Text]
errs = (MsgEnvelope GhcMessage -> Maybe Text)
-> [MsgEnvelope GhcMessage] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text -> Text] -> MsgEnvelope GhcMessage -> Maybe Text
formatDiagnostic [Text -> Text]
filePathMods)
           ([MsgEnvelope GhcMessage] -> [Text])
-> ([MsgEnvelope GhcMessage] -> [MsgEnvelope GhcMessage])
-> [MsgEnvelope GhcMessage]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope GhcMessage -> Bool)
-> [MsgEnvelope GhcMessage] -> [MsgEnvelope GhcMessage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\MsgEnvelope GhcMessage
env -> Bool
includeParserErrors Bool -> Bool -> Bool
|| Bool -> Bool
not (GhcMessage -> Bool
isParseError (MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
Ghc.errMsgDiagnostic MsgEnvelope GhcMessage
env)))
           ([MsgEnvelope GhcMessage] -> [Text])
-> [MsgEnvelope GhcMessage] -> [Text]
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
Ghc.bagToList Bag (MsgEnvelope GhcMessage)
envelopes
      First Maybe FilePath
mFile =
        (MsgEnvelope GhcMessage -> First FilePath)
-> Bag (MsgEnvelope GhcMessage) -> First FilePath
forall m a. Monoid m => (a -> m) -> Bag a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
          (Maybe FilePath -> First FilePath
forall a. Maybe a -> First a
First (Maybe FilePath -> First FilePath)
-> (MsgEnvelope GhcMessage -> Maybe FilePath)
-> MsgEnvelope GhcMessage
-> First FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString -> FilePath) -> Maybe FastString -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FastString -> FilePath
Ghc.unpackFS (Maybe FastString -> Maybe FilePath)
-> (MsgEnvelope GhcMessage -> Maybe FastString)
-> MsgEnvelope GhcMessage
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe FastString
Ghc.srcSpanFileName_maybe (SrcSpan -> Maybe FastString)
-> (MsgEnvelope GhcMessage -> SrcSpan)
-> MsgEnvelope GhcMessage
-> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
Ghc.errMsgSpan)
          (Bag (MsgEnvelope GhcMessage) -> First FilePath)
-> Bag (MsgEnvelope GhcMessage) -> First FilePath
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Ghc.getMessages Messages GhcMessage
messages
  Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FilePath
mFile ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Text] -> FilePath -> ErrMap -> STM ()
forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
SM.insert [Text]
errs FilePath
file ErrMap
errMap
    TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
errsUpdated Bool
True

-- | Remove errors for files that no longer exist
pruneDeletedFiles :: [(FilePath, [T.Text])] -> ErrMap -> IO [T.Text]
pruneDeletedFiles :: [(FilePath, [Text])] -> ErrMap -> IO [Text]
pruneDeletedFiles [(FilePath, [Text])]
errs ErrMap
errMap = do
  let files :: [FilePath]
files = (FilePath, [Text]) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, [Text]) -> FilePath)
-> [(FilePath, [Text])] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FilePath, [Text])]
errs
  [FilePath]
deletedFiles <- ([Maybe FilePath] -> [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe FilePath] -> IO [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
    [FilePath]
-> (FilePath -> IO (Maybe FilePath)) -> IO [Maybe FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FilePath]
files ((FilePath -> IO (Maybe FilePath)) -> IO [Maybe FilePath])
-> (FilePath -> IO (Maybe FilePath)) -> IO [Maybe FilePath]
forall a b. (a -> b) -> a -> b
$ \FilePath
file ->
      FilePath -> IO Bool
Dir.doesFileExist FilePath
file IO Bool -> (Bool -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
        Bool
False -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> STM ()) -> [FilePath] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> ErrMap -> STM ()
forall key value. Hashable key => key -> Map key value -> STM ()
`SM.delete` ErrMap
errMap) [FilePath]
deletedFiles
  [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> IO [Text])
-> ([(FilePath, [Text])] -> [Text])
-> [(FilePath, [Text])]
-> IO [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, [Text]) -> [Text]) -> [(FilePath, [Text])] -> [Text]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (FilePath, [Text]) -> [Text]
forall a b. (a, b) -> b
snd ([(FilePath, [Text])] -> IO [Text])
-> [(FilePath, [Text])] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ ((FilePath, [Text]) -> Bool)
-> [(FilePath, [Text])] -> [(FilePath, [Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((FilePath, [Text]) -> Bool) -> (FilePath, [Text]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
deletedFiles) (FilePath -> Bool)
-> ((FilePath, [Text]) -> FilePath) -> (FilePath, [Text]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, [Text]) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, [Text])]
errs

-- | Currently no good way to get warnings from desugarer, so a log action hook
-- is used to get the raw SDoc. Note: unfortunately this will also capture
-- warnings from the typechecker.
logHookHack :: IORef (Ghc.Messages Ghc.GhcMessage) -> Ghc.HscEnv -> Ghc.LogAction -> Ghc.LogAction
logHookHack :: IORef (Messages GhcMessage) -> HscEnv -> LogAction -> LogAction
logHookHack IORef (Messages GhcMessage)
dsWarnVar HscEnv
hscEnv LogAction
logAction LogFlags
flags MessageClass
clss SrcSpan
srcSpan SDoc
sdoc = do
  case MessageClass
clss of
    Ghc.MCDiagnostic Severity
Ghc.SevWarning ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_ -> 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
            mkUnknownDiag :: DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
mkUnknownDiag =
#if MIN_VERSION_ghc(9,8,0)
              (DiagnosticOpts DiagnosticMessage
 -> DiagnosticOpts DiagnosticMessage)
-> DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
Ghc.UnknownDiagnostic DiagnosticOpts DiagnosticMessage
-> DiagnosticOpts DiagnosticMessage
forall a. a -> a
id
#else
              Ghc.UnknownDiagnostic
#endif
            ghcMessage :: GhcMessage
ghcMessage = DsMessage -> GhcMessage
Ghc.GhcDsMessage (DsMessage -> GhcMessage)
-> (UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
    -> DsMessage)
-> UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
-> GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnknownDiagnostic (DiagnosticOpts DiagnosticMessage) -> DsMessage
UnknownDiagnostic (DiagnosticOpts DsMessage) -> DsMessage
Ghc.DsUnknownMessage (UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
 -> GhcMessage)
-> UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
-> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DiagnosticMessage)
mkUnknownDiag DiagnosticMessage
diag
            warn :: MsgEnvelope GhcMessage
warn = DiagOpts
-> SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
Ghc.mkMsgEnvelope DiagOpts
diagOpts SrcSpan
srcSpan NamePprCtx
Ghc.neverQualify GhcMessage
ghcMessage
        IORef (Messages GhcMessage)
-> (Messages GhcMessage -> Messages GhcMessage) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Messages GhcMessage)
dsWarnVar (MsgEnvelope GhcMessage
-> Messages GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e -> Messages e
Ghc.addMessage MsgEnvelope GhcMessage
warn)
    MessageClass
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  LogAction
logAction LogFlags
flags MessageClass
clss SrcSpan
srcSpan SDoc
sdoc