ghci-quickfix 0.1.1.0 → 0.1.1.1
raw patch · 5 files changed
+97/−69 lines, 5 filesdep +containersdep +safe-exceptionsdep −deferred-foldsdep −foldldep −stm-containersPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, safe-exceptions
Dependencies removed: deferred-folds, foldl, stm-containers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +3/−1
- ghci-quickfix.cabal +4/−4
- src/GhciQuickfix.hs +87/−61
- src/GhciQuickfix/GhcFacade.hs +0/−1
- test/Main.hs +3/−2
CHANGELOG.md view
@@ -1,10 +1,12 @@ # Revision history for ghci-quickfix +## 0.1.1.1 -- 2026-07-14+* Sort errors in quickfix file by order of emission+ ## 0.1.1.0 -- 2026-05-13 * Support GHC 9.14 * Drop support for 9.6-* Sort errors in quickfix file by order of emission ## 0.1.0.0 -- 2026-01-09
ghci-quickfix.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghci-quickfix-version: 0.1.1.0+version: 0.1.1.1 synopsis: GHC plugin that writes errors to a file for use with quickfix description: GHC plugin that writes errors to a file for use with vim/nvim's quickfix system license: BSD-3-Clause@@ -31,11 +31,10 @@ ghc >= 9.8 && < 9.15, text, async >= 2.2 && < 3,- stm-containers >= 1.2 && < 1.3, directory, stm,- deferred-folds >= 0.9 && < 1,- foldl >= 1 && < 2+ containers,+ safe-exceptions hs-source-dirs: src default-language: GHC2021 @@ -62,6 +61,7 @@ -- default-language: GHC2021 -- hs-source-dirs: play -- main-is: Main.hs+-- other-modules: Test -- build-depends: -- base, -- ghci-quickfix
src/GhciQuickfix.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-}@@ -7,38 +6,57 @@ , pluginOffByDefault ) where -import Control.Concurrent (threadDelay)+import Control.Concurrent (threadDelay, MVar, newEmptyMVar, tryPutMVar) import qualified Control.Concurrent.Async as Async import Control.Concurrent.STM.TVar-import Control.Exception-import qualified Control.Foldl as F+import Control.Exception.Safe import Control.Monad import Control.Monad.STM import qualified Data.Char as Char import Data.Either (partitionEithers) import Data.Foldable+import Data.Functor import Data.IORef import qualified Data.List as List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid (First(..)) import qualified Data.Ord as Ord+import qualified Data.Set as Set 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 System.IO (stderr, hPutStrLn)+import System.IO.Unsafe (unsafePerformIO) import qualified GhciQuickfix.GhcFacade as Ghc --- | STM Map is used to avoid contention between modules compiled in parrallel,--- although it isn't clear if it actually helps since contention will still--- happen with the STVars used in the same transaction.--- The Int paired with the errors is used for ordering.-type ErrMap = SM.Map FilePath (Int, [T.Text])+type ErrMap = TVar (Map FilePath Errors) +data Errors = Errors+ { ordering :: !Int -- track the ordering of module compilation+ , errors :: ![T.Text]+ }++{-# NOINLINE globalErrMap #-}+globalErrMap :: ErrMap+globalErrMap = unsafePerformIO (newTVarIO mempty)++{-# NOINLINE globalErrsUpdated #-}+globalErrsUpdated :: TVar Bool+globalErrsUpdated = unsafePerformIO (newTVarIO False)++{-# NOINLINE globalCounter #-}+globalCounter :: IORef Int+globalCounter = unsafePerformIO (newIORef 0)++{-# NOINLINE writerThreadLock #-}+writerThreadLock :: MVar ()+writerThreadLock = unsafePerformIO newEmptyMVar+ plugin :: Ghc.Plugin plugin = Ghc.defaultPlugin { Ghc.driverPlugin = modifyHscEnv False@@ -52,19 +70,24 @@ -- | 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 mErrFilePath errMap updated = forever $ do- msgs <- atomically $ do- check =<< readTVar updated- writeTVar updated False- DF.foldM (F.generalize F.list) (SM.unfoldlM errMap)- prunedMsgs <- pruneDeletedFiles msgs errMap- TIO.writeFile (fromMaybe "errors.err" mErrFilePath)- . T.unlines . foldMap snd- -- Sort in reverse so that the first error in the list is the last one to- -- be emitted by the compiler- $ List.sortOn Ord.Down prunedMsgs- threadDelay 200_000 -- 200ms+writeQuickfixLoop :: Maybe FilePath -> IO ()+writeQuickfixLoop mErrFilePath = forever $+ handleAny+ (\err -> do+ hPutStrLn stderr $ "ghci-quickfix: " <> displayException err+ threadDelay 1_000_000+ )+ $ do+ msgs <- atomically $ do+ isUpdated <- swapTVar globalErrsUpdated False+ check isUpdated+ Map.toList <$> readTVar globalErrMap+ prunedMsgs <- pruneDeletedFiles msgs+ TIO.writeFile (fromMaybe "errors.err" mErrFilePath)+ . T.unlines . foldMap' errors+ -- sort so that the last compiled module is the first in the list+ $ List.sortOn (Ord.Down . ordering) prunedMsgs+ threadDelay 200_000 -- 200ms parseFilePathModifier :: [Ghc.CommandLineOption] -> IO (Either String [T.Text -> T.Text]) parseFilePathModifier opts = do@@ -88,7 +111,7 @@ parseQuickfixFilePath :: [Ghc.CommandLineOption] -> IO (Maybe FilePath) parseQuickfixFilePath opts = do envPath <- Env.lookupEnv "GHCI_QUICKFIX_FILE"- pure $ getFirst $ foldMap (First . List.stripPrefix "--quickfix-file=") opts <> First envPath+ pure $ getFirst $ foldMap' (First . List.stripPrefix "--quickfix-file=") opts <> First envPath parseIncludeParserErrors :: [Ghc.CommandLineOption] -> IO Bool parseIncludeParserErrors opts = do@@ -109,17 +132,16 @@ parseFilePathModifier opts >>= \case Left err -> fail err Right filePathMods -> do- errMap <- SM.newIO- errsUpdated <- newTVarIO False- counter <- newTVarIO 0 quickfixFilePath <- parseQuickfixFilePath opts- void . Async.async $ writeQuickfixLoop quickfixFilePath errMap errsUpdated+ started <- tryPutMVar writerThreadLock ()+ when started $+ void . Async.async $ writeQuickfixLoop quickfixFilePath includeParserErrors <- parseIncludeParserErrors opts- pure hscEnv { Ghc.hsc_hooks = modifyHooks includeParserErrors filePathMods (Ghc.hsc_hooks hscEnv) errMap errsUpdated counter }+ pure hscEnv { Ghc.hsc_hooks = modifyHooks includeParserErrors filePathMods (Ghc.hsc_hooks hscEnv) } else pure hscEnv where- modifyHooks includeParserErrors filePathMods hooks (errMap :: ErrMap) (errsUpdated :: TVar Bool) (counter :: TVar Int) =+ modifyHooks includeParserErrors filePathMods hooks = let runPhaseOrExistingHook :: Ghc.TPhase res -> IO res runPhaseOrExistingHook = maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h) $ Ghc.runPhaseHook hooks@@ -132,7 +154,7 @@ dsWarnVar <- newIORef mempty try (runPhaseOrExistingHook $ addDsLogHook (logHookHack dsWarnVar hscEnv) phase) >>= \case Left err@(Ghc.SourceError msgs) -> do- handleMessages includeParserErrors filePathMods errMap errsUpdated counter msgs+ handleMessages includeParserErrors filePathMods msgs throw err Right res -> do dsWarns <- readIORef dsWarnVar@@ -142,12 +164,12 @@ then atomically $ do -- Module compiled without errors or warnings so delete map entry if exists let modFile = Ghc.ms_hspp_file modSummary- SM.lookup modFile errMap >>= \case- Nothing -> pure ()- Just _ -> do- SM.delete (Ghc.ms_hspp_file modSummary) errMap- writeTVar errsUpdated True- else handleMessages includeParserErrors filePathMods errMap errsUpdated counter $+ entryDeleted <- stateTVar globalErrMap $ \m ->+ let (mOld, m') = Map.updateLookupWithKey (\_ _ -> Nothing) modFile m+ in (isJust mOld, m')+ when entryDeleted $+ writeTVar globalErrsUpdated True+ else handleMessages includeParserErrors filePathMods $ if length tcWarnings == length dsWarns then tcWarnings -- has preferred formatting else dsWarns@@ -189,8 +211,8 @@ line = Ghc.srcLocLine startLoc col = Ghc.srcLocCol startLoc truncateMsg txt =- let truncated = T.take 200 txt- in if T.length txt > 200 then truncated <> "…" else truncated+ let truncated = T.take 201 txt+ in if T.length truncated > 200 then T.dropEnd 1 truncated <> "…" else txt msg = truncateMsg . T.intercalate " • " $ T.unwords . T.words . T.pack . Ghc.renderWithContext ctx@@ -205,40 +227,44 @@ handleMessages :: Bool -> [T.Text -> T.Text]- -> ErrMap- -> TVar Bool- -> TVar Int -> Ghc.Messages Ghc.GhcMessage -> IO ()-handleMessages includeParserErrors filePathMods errMap errsUpdated counter messages = do+handleMessages includeParserErrors filePathMods messages = do let envelopes = Ghc.getMessages messages isParseError = \case Ghc.GhcPsMessage{} -> True _ -> False -- Filter out parse errors unless explicitly included errs = mapMaybe (formatDiagnostic filePathMods)+ -- sort to match the order of appearance in GHCi+ . List.sortOn+ ( Ord.Down . fmap (\s -> (Ghc.srcSpanStartLine s, Ghc.srcSpanStartCol s))+ . Ghc.srcSpanToRealSrcSpan . Ghc.errMsgSpan+ ) . filter (\env -> includeParserErrors || not (isParseError (Ghc.errMsgDiagnostic env))) $ Ghc.bagToList envelopes First mFile =- foldMap+ foldMap' (First . fmap Ghc.unpackFS . Ghc.srcSpanFileName_maybe . Ghc.errMsgSpan)- $ Ghc.getMessages messages- for_ mFile $ \file -> atomically $ do- n <- stateTVar counter (\x -> let !nx = x + 1 in (x, nx))- SM.insert (n, errs) file errMap- writeTVar errsUpdated True+ envelopes+ for_ mFile $ \file ->+ unless (null errs) $ do+ n <- atomicModifyIORef' globalCounter (\x -> let !nx = x + 1 in (nx, x))+ atomically $ do+ modifyTVar' globalErrMap (Map.insert file (Errors n errs))+ writeTVar globalErrsUpdated True -- | Remove errors for files that no longer exist-pruneDeletedFiles :: [(FilePath, (Int, [T.Text]))] -> ErrMap -> IO [(Int, [T.Text])]-pruneDeletedFiles errs errMap = do+pruneDeletedFiles :: [(FilePath, Errors)] -> IO [Errors]+pruneDeletedFiles errs = do let files = fst <$> errs- deletedFiles <- fmap catMaybes $- for files $ \file ->- Dir.doesFileExist file >>= \case- True -> pure Nothing- False -> pure (Just file)- atomically $ traverse_ (`SM.delete` errMap) deletedFiles- pure . fmap snd $ filter (not . (`elem` deletedFiles) . fst) errs+ deletedFiles <-+ (`foldMap'` files) $ \file ->+ Dir.doesFileExist file <&> \case+ True -> mempty+ False -> Set.singleton file+ atomically $ modifyTVar' globalErrMap (`Map.withoutKeys` deletedFiles)+ pure . fmap snd $ filter ((`Set.notMember` deletedFiles) . fst) 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@@ -256,6 +282,6 @@ diagOpts = Ghc.initDiagOpts $ Ghc.hsc_dflags hscEnv ghcMessage = Ghc.GhcDsMessage . Ghc.DsUnknownMessage $ Ghc.mkUnknownDiagnostic diag warn = Ghc.mkMsgEnvelope diagOpts srcSpan Ghc.neverQualify ghcMessage- modifyIORef dsWarnVar (Ghc.addMessage warn)+ modifyIORef' dsWarnVar (Ghc.addMessage warn) _ -> pure () logAction flags clss srcSpan sdoc
src/GhciQuickfix/GhcFacade.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module GhciQuickfix.GhcFacade ( module Ghc ) where
test/Main.hs view
@@ -68,13 +68,14 @@ void $ Proc.waitForProcess h hClose hDevNull + qfExists' <- Dir.doesFileExist qfFile -- Check that quickfix file was created and has expected contents- actualContents <- readFile qfFile+ actualContents <- if qfExists' then readFile qfFile else pure "" expectedContents <- readFile $ qfFile ++ ".expected" assertEqual "Expected quickfix output" expectedContents actualContents -- Clean up- Dir.removeFile qfFile+ when qfExists' (Dir.removeFile qfFile) runTestWarningFix :: Assertion runTestWarningFix = do