ghci-quickfix (empty) → 0.1.0.0
raw patch · 7 files changed
+728/−0 lines, 7 filesdep +asyncdep +basedep +deferred-folds
Dependencies added: async, base, deferred-folds, directory, foldl, ghc, ghci-quickfix, process, stm, stm-containers, tasty, tasty-hunit, text
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +212/−0
- ghci-quickfix.cabal +68/−0
- src/GhciQuickfix.hs +249/−0
- src/GhciQuickfix/GhcFacade.hs +27/−0
- test/Main.hs +138/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for ghci-quickfix++## 0.1.0.0 -- 2026-01-09++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Aaron Allen+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,212 @@+# ghci-quickfix 📝++This is a GHC plugin that will write diagnostics to a file during compilation,+which can then be used with `vim`/`nvim`'s quickfix feature. By default, the file+is `errors.err` in the project root directory but this can be customized (see plugin options).++**NOTE:** If you're using this plugin via+[`repl-alliance`](https://github.com/aaronallen8455/repl-alliance), you need to+explicitly enable it by passing `--fplugin-opt ReplAlliance:--quickfix` to GHC+or by setting the environment variable `GHCI_QUICKFIX_ENABLED=true`.++## Usage++This plugin is intended to be used with GHCi or adjacent utilities such as+`ghcid` and `ghciwatch` as a development tool, not as a package dependency.++### Stack Projects++To use with a stack project (you may need to add `ghci-quickfix` to your+`extra-deps` first):++```bash+stack repl my-project --package ghci-quickfix --ghci-options='-fplugin GhciQuickfix'+```++### Cabal Projects++To use with a cabal project (you may need to run `cabal update` first):++```bash+cabal repl my-project --build-depends ghci-quickfix --repl-options='-fplugin GhciQuickfix'+```++## Vim/Neovim Integration++After starting your REPL with the plugin enabled, you can load errors in Vim:++```vim+:cf errors.err+```++The `errors.err` argument can be omitted since it is the default file.++Or to update without jumping to the first error:++```vim+:cg errors.err+```++Navigate between error locations using `:cn` (next) and `:cp` (previous).++To get highlighting for errors and warnings in the editor, you can turn the+quickfix entries into diagnostics. The following snippet can be added to your+`init.lua` file to accomplish this.++```lua+-- [[ Quickfix to diagnostics ]]+-- Configure errorformat to distinguish between warning and error type.+vim.o.errorformat = '%f:%l:%c: %tarning: %m,%f:%l:%c: %trror: %m,' .. vim.o.errorformat++-- Create namespace for quickfix diagnostics+local qf_ns = vim.api.nvim_create_namespace('quickfix_diagnostics')++-- Configure diagnostic display for quickfix namespace+vim.diagnostic.config({+ underline = true,+ virtual_text = false,+ signs = true,+ update_in_insert = false,+}, qf_ns)++-- Helper function to create diagnostic entry from quickfix item+local function create_diagnostic_from_qf_item(item)+ local severity = vim.diagnostic.severity.ERROR++ -- Determine severity based on type field+ if item.type == 'W' or item.type == 'w' then+ severity = vim.diagnostic.severity.WARN+ end++ -- Handle column range - if no end_col, highlight to end of line+ local col_start = (item.col or 1) - 1+ local col_end = nil+ local end_lnum = nil++ if item.end_col and item.end_col > 0 and item.end_lnum then+ col_end = item.end_col+ end_lnum = item.end_lnum - 1+ end++ return {+ lnum = item.lnum - 1,+ col = col_start,+ end_lnum = end_lnum,+ end_col = col_end,+ severity = severity,+ message = item.text or '',+ source = 'quickfix',+ }+end++-- Function to convert quickfix entries to diagnostics and apply to all buffers+local function quickfix_to_diagnostics()+ -- Clear all quickfix diagnostics from all buffers+ vim.diagnostic.reset(qf_ns)++ local qf_list = vim.fn.getqflist()+ local diagnostics_by_buf = {}++ for _, item in ipairs(qf_list) do+ if item.bufnr > 0 and item.lnum > 0 then+ if not diagnostics_by_buf[item.bufnr] then+ diagnostics_by_buf[item.bufnr] = {}+ end+ table.insert(diagnostics_by_buf[item.bufnr], create_diagnostic_from_qf_item(item))+ end+ end++ -- Set diagnostics for each buffer+ for bufnr, diagnostics in pairs(diagnostics_by_buf) do+ vim.diagnostic.set(qf_ns, bufnr, diagnostics, {})+ end+end++-- Function to apply diagnostics for a specific buffer+local function apply_quickfix_diagnostics_for_buffer(bufnr)+ local qf_list = vim.fn.getqflist()+ local diagnostics = {}++ for _, item in ipairs(qf_list) do+ if item.bufnr == bufnr and item.lnum > 0 then+ table.insert(diagnostics, create_diagnostic_from_qf_item(item))+ end+ end++ vim.diagnostic.set(qf_ns, bufnr, diagnostics, {})+end++-- Auto-convert quickfix entries to diagnostics when loading from file+vim.api.nvim_create_autocmd('QuickFixCmdPost', {+ pattern = '[cg]file,[cg]getfile',+ callback = function()+ quickfix_to_diagnostics()+ end,+})++-- Reapply diagnostics when a buffer is read (handles newly opened buffers)+vim.api.nvim_create_autocmd('BufReadPost', {+ pattern = '*',+ callback = function(args)+ local qf_list = vim.fn.getqflist()+ if #qf_list == 0 then+ return+ end++ -- Only apply diagnostics for this specific buffer if it has quickfix entries+ local bufnr = args.buf+ for _, item in ipairs(qf_list) do+ if item.bufnr == bufnr then+ apply_quickfix_diagnostics_for_buffer(bufnr)+ return+ end+ end+ end,+})+```++## Plugin Options++Plugin options are passed using the `--fplugin-opt` flag. For example:++```bash+-fplugin GhciQuickfix -fplugin-opt GhciQuickfix:--quickfix-file=my-errors.err+```++### Available Options++- **`--quickfix-file=<path>`**+ Specify the output file path for diagnostics.+ Default: `errors.err`+ Alternative: Set environment variable `GHCI_QUICKFIX_FILE=<path>`++- **`--quickfix-include-parser-errors`**+ Include parser errors in the quickfix file.+ Default: Parser errors are excluded (HLint typically reports them)+ Alternative: Set environment variable `GHCI_QUICKFIX_INCLUDE_PARSER_ERRORS=true`++- **`--quickfix-path-replace=<needle>:<replace>`**+ Replace text in file paths in the quickfix output.+ Example: `--quickfix-path-replace=/home/user:/Users/user`+ Can be specified multiple times for multiple replacements.+ Useful for containerized or remote development environments.+ Alternative: Set environment variable `GHCI_QUICKFIX_PATH_REPLACE=<needle>:<replace>`++- **`--quickfix`**+ Explicitly enable the plugin when using `pluginOffByDefault` (e.g., with repl-alliance).+ Alternative: Set environment variable `GHCI_QUICKFIX_ENABLED=true`++## Output Format++The plugin generates quickfix entries in GCC-style format:++```+filename.hs:line:col: severity: message+```++This format is automatically recognized by Vim's quickfix system.++## Compatibility++This plugin aims to support the 4 latest GHC major releases (i.e. `9.6.*` through `9.12.*`).+Check the cabal file for the currently supported versions.
+ ghci-quickfix.cabal view
@@ -0,0 +1,68 @@+cabal-version: 3.0+name: ghci-quickfix+version: 0.1.0.0+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+license-file: LICENSE+author: Aaron Allen+maintainer: aaronallen8455@gmail.com+-- copyright:+category: Development+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md+tested-with: GHC == 9.12.1, GHC == 9.10.1, GHC == 9.8.1, GHC == 9.6.1+-- extra-source-files:++source-repository head+ type: git+ location: https://github.com/aaronallen8455/ghci-quickfix++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: GhciQuickfix+ other-modules: GhciQuickfix.GhcFacade+ -- other-extensions:+ build-depends: base < 4.23,+ ghc >= 9.6 && < 9.13,+ text,+ async >= 2.2 && < 3,+ stm-containers >= 1.2 && < 1.3,+ directory,+ stm,+ deferred-folds >= 0.9 && < 1,+ foldl >= 1 && < 2+ hs-source-dirs: src+ default-language: GHC2021++test-suite ghci-quickfix-test+ import: warnings+ default-language: GHC2021+ -- other-modules:+ -- other-extensions:+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -threaded -with-rtsopts=-N+ build-depends:+ base,+ ghci-quickfix,+ tasty,+ tasty-hunit,+ process,+ directory,+ async++-- executable play+-- import: warnings+-- default-language: GHC2021+-- hs-source-dirs: play+-- main-is: Main.hs+-- build-depends:+-- base,+-- ghci-quickfix+-- ghc-options: -fplugin GhciQuickfix
+ src/GhciQuickfix.hs view
@@ -0,0 +1,249 @@+{-# 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 = 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+ { 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 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 prunedMsgs+ threadDelay 200_000 -- 200ms++parseFilePathModifier :: [Ghc.CommandLineOption] -> IO (Either String [T.Text -> T.Text])+parseFilePathModifier opts = do+ envMod <- getEnvModifier+ pure $ case partitionEithers (mapMaybe getModifier opts ++ maybeToList envMod) of+ ([], modifiers) -> Right modifiers+ (errs, _) -> Left (unlines errs)+ where+ parseReplacement :: String -> String -> Either String (T.Text -> T.Text)+ parseReplacement source pat =+ case T.split (== ':') (T.pack pat) of+ [needle, replace] -> Right $ T.replace needle replace+ _ -> Left $ "Malformed " ++ source ++ ": expected format 'needle:replace', got '" ++ pat ++ "'"+ getEnvModifier = do+ mPat <- Env.lookupEnv "GHCI_QUICKFIX_PATH_REPLACE"+ pure $ parseReplacement "GHCI_QUICKFIX_PATH_REPLACE environment variable" <$> mPat+ getModifier opt = do+ pat <- stripPrefix "--quickfix-path-replace=" opt+ Just $ parseReplacement "--quickfix-path-replace argument" pat++parseQuickfixFilePath :: [Ghc.CommandLineOption] -> IO (Maybe FilePath)+parseQuickfixFilePath opts = do+ envPath <- Env.lookupEnv "GHCI_QUICKFIX_FILE"+ pure $ getFirst $ foldMap (First . stripPrefix "--quickfix-file=") opts <> First envPath++parseIncludeParserErrors :: [Ghc.CommandLineOption] -> IO Bool+parseIncludeParserErrors opts = do+ envEnabled <- (== Just "true") . fmap (map Char.toLower)+ <$> Env.lookupEnv "GHCI_QUICKFIX_INCLUDE_PARSER_ERRORS"+ pure $ elem "--quickfix-include-parser-errors" opts || envEnabled++explicitlyEnabled :: [Ghc.CommandLineOption] -> IO Bool+explicitlyEnabled opts = do+ envEnabled <- (== Just "true") . fmap (map Char.toLower)+ <$> Env.lookupEnv "GHCI_QUICKFIX_ENABLED"+ pure $ elem "--quickfix" opts || envEnabled++modifyHscEnv :: Bool -> [Ghc.CommandLineOption] -> Ghc.HscEnv -> IO Ghc.HscEnv+modifyHscEnv isOffByDefault opts hscEnv = do+ enabled <- explicitlyEnabled opts+ if not isOffByDefault || enabled then do+ parseFilePathModifier opts >>= \case+ Left err -> fail err+ Right filePathMods -> do+ errMap <- SM.newIO+ errsUpdated <- newTVarIO False+ quickfixFilePath <- parseQuickfixFilePath opts+ void . Async.async $ writeQuickfixLoop quickfixFilePath errMap errsUpdated+ includeParserErrors <- parseIncludeParserErrors opts+ pure hscEnv { Ghc.hsc_hooks = modifyHooks includeParserErrors filePathMods (Ghc.hsc_hooks hscEnv) errMap errsUpdated }+ else+ pure hscEnv+ where+ modifyHooks includeParserErrors filePathMods hooks (errMap :: ErrMap) (errsUpdated :: TVar Bool) =+ let runPhaseOrExistingHook :: Ghc.TPhase res -> IO res+ runPhaseOrExistingHook = maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h)+ $ Ghc.runPhaseHook hooks+ phaseHook :: Ghc.PhaseHook+ phaseHook = Ghc.PhaseHook $ \phase -> do+ let tcWarnings :: Ghc.Messages Ghc.GhcMessage+ tcWarnings = case phase of+ Ghc.T_HscPostTc _ _ _ msgs _ -> msgs+ _ -> mempty+ dsWarnVar <- newIORef mempty+ try (runPhaseOrExistingHook $ addDsLogHook (logHookHack dsWarnVar hscEnv) phase) >>= \case+ Left err@(Ghc.SourceError msgs) -> do+ handleMessages includeParserErrors filePathMods errMap errsUpdated msgs+ throw err+ Right res -> do+ dsWarns <- readIORef dsWarnVar+ case phase of+ Ghc.T_HscPostTc _ modSummary _ _ _ ->+ if Ghc.isEmptyMessages dsWarns+ 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 $+ if length tcWarnings == length dsWarns+ then tcWarnings -- has preferred formatting+ else dsWarns+ _ -> pure ()+ pure res+ in hooks+ { Ghc.runPhaseHook = Just phaseHook }++addDsLogHook :: (Ghc.LogAction -> Ghc.LogAction) -> Ghc.TPhase res -> Ghc.TPhase res+addDsLogHook logHook = \case+ Ghc.T_HscPostTc hscEnv a b c d ->+ Ghc.T_HscPostTc (addHook hscEnv) a b c d+ x -> x+ where+ addHook 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 filePathMods m = do+ severity <- case Ghc.errMsgSeverity m of+ Ghc.SevIgnore -> Nothing+ -- ^ Ignore this message, for example in case of suppression of warnings+ -- users don't want to see.+ Ghc.SevWarning -> Just "warning"+ Ghc.SevError -> Just "error"+ startLoc <- Ghc.realSrcSpanStart <$> Ghc.srcSpanToRealSrcSpan (Ghc.errMsgSpan m)+ let diag = Ghc.errMsgDiagnostic m+ opts = (Ghc.defaultDiagnosticOpts @Ghc.GhcMessage)+ { Ghc.tcMessageOpts = (Ghc.defaultDiagnosticOpts @Ghc.TcRnMessage)+ { Ghc.tcOptsShowContext = False -- Omit all the additional stuff+ }+ }+ ctx = Ghc.defaultSDocContext+ { Ghc.sdocStyle = Ghc.mkErrStyle (Ghc.errMsgContext m)+ , Ghc.sdocCanUseUnicode = True+ }++ file = TE.decodeUtf8 . Ghc.bytesFS $ Ghc.srcLocFile startLoc+ 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+ msg = truncateMsg . T.intercalate " • "+ $ T.unwords . T.words . T.pack+ . Ghc.renderWithContext ctx+ <$> filter (not . Ghc.isEmpty ctx) (Ghc.unDecorated (Ghc.diagnosticMessage opts diag))++ -- filename:line:column: error: message+ Just $ foldl' (flip ($)) file filePathMods+ <> ":" <> T.pack (show line) <> ":" <> T.pack (show col) <> ": "+ <> severity <> ": " <> msg++-- | Update state given all diagnostics for a module+handleMessages :: Bool -> [T.Text -> T.Text] -> ErrMap -> TVar Bool -> Ghc.Messages Ghc.GhcMessage -> IO ()+handleMessages includeParserErrors filePathMods errMap errsUpdated messages = do+ let envelopes = Ghc.getMessages messages+ isParseError = \case+ Ghc.GhcPsMessage{} -> True+ _ -> False+ -- Filter out parse errors unless explicitly included+ errs = mapMaybe (formatDiagnostic filePathMods)+ . filter (\env -> includeParserErrors || not (isParseError (Ghc.errMsgDiagnostic env)))+ $ Ghc.bagToList envelopes+ First mFile =+ foldMap+ (First . fmap Ghc.unpackFS . Ghc.srcSpanFileName_maybe . Ghc.errMsgSpan)+ $ Ghc.getMessages messages+ for_ mFile $ \file -> atomically $ do+ SM.insert errs file errMap+ writeTVar errsUpdated True++-- | Remove errors for files that no longer exist+pruneDeletedFiles :: [(FilePath, [T.Text])] -> ErrMap -> IO [T.Text]+pruneDeletedFiles errs errMap = 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 . foldMap snd $ filter (not . (`elem` 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+-- warnings from the typechecker.+logHookHack :: IORef (Ghc.Messages Ghc.GhcMessage) -> Ghc.HscEnv -> Ghc.LogAction -> Ghc.LogAction+logHookHack dsWarnVar hscEnv logAction flags clss srcSpan sdoc = do+ case clss of+ Ghc.MCDiagnostic Ghc.SevWarning _ _ -> do+ let diag =+ Ghc.DiagnosticMessage+ { Ghc.diagMessage = Ghc.mkSimpleDecorated sdoc+ , Ghc.diagReason = Ghc.WarningWithoutFlag+ , Ghc.diagHints = []+ }+ diagOpts = Ghc.initDiagOpts $ Ghc.hsc_dflags hscEnv+ mkUnknownDiag =+#if MIN_VERSION_ghc(9,8,0)+ Ghc.UnknownDiagnostic id+#else+ Ghc.UnknownDiagnostic+#endif+ ghcMessage = Ghc.GhcDsMessage . Ghc.DsUnknownMessage $ mkUnknownDiag diag+ warn = Ghc.mkMsgEnvelope diagOpts srcSpan Ghc.neverQualify ghcMessage+ modifyIORef dsWarnVar (Ghc.addMessage warn)+ _ -> pure ()+ logAction flags clss srcSpan sdoc
+ src/GhciQuickfix/GhcFacade.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+module GhciQuickfix.GhcFacade+ ( module Ghc+ ) where++import GHC.Driver.Plugins as Ghc+import GHC.Driver.Env.Types as Ghc+import GHC.Driver.Hooks as Ghc+import GHC.Driver.Pipeline.Phases as Ghc+import GHC.Driver.Pipeline.Execute as Ghc+import GHC.Types.SourceError as Ghc+import GHC.Types.Error as Ghc+import GHC.Unit.Module.ModSummary as Ghc+import GHC.Driver.Errors.Types as Ghc+import GHC.Types.SrcLoc as Ghc+import GHC.Data.FastString as Ghc+import GHC.Utils.Outputable as Ghc+import GHC.Utils.Error as Ghc+import GHC.Data.Bag as Ghc+import GHC.Tc.Errors.Types as Ghc+import GHC.Tc.Types as Ghc hiding (DefaultingPlugin, TcPlugin)+import GHC.Utils.Logger as Ghc+import GHC.Driver.Config.Diagnostic as Ghc+import GHC.HsToCore.Errors.Types as Ghc+#if !MIN_VERSION_ghc(9,8,0)+import GHC.Tc.Errors.Ppr as Ghc+#endif
+ test/Main.hs view
@@ -0,0 +1,138 @@+module Main (main) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race)+import Control.Monad+import Data.List (isInfixOf)+import qualified System.Directory as Dir+import System.IO+import qualified System.Process as Proc+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ testCase "ParseError1" $ runTest "ParseError1"+ , testCase "ParseError2" $ runTest "ParseError2"+ , testCase "TypeErr1" $ runTest "TypeErr1"+ , testCase "UnusedVar" $ runTest "UnusedVar"+ , testCase "IncompletePat" $ runTest "IncompletePat"+ , testCase "MultiMod" $ runTest "MultiMod"+ , testCase "WarningFix" runTestWarningFix+ ]++testModulePath :: String -> FilePath+testModulePath name = "test-modules/" <> name++-- Wait for GHCi prompt by reading output until we see "ghci>"+waitForPrompt :: Handle -> IO ()+waitForPrompt hOut = void $ race (go "") (threadDelay 6_000_000)+ where+ go acc = do+ ready <- hReady hOut+ if ready+ then do+ c <- hGetChar hOut+ let acc' = take 10 (c : acc) -- Keep last 10 chars+ if "ghci>" `isInfixOf` reverse acc'+ then threadDelay 300_000 -- Brief delay for background thread+ else go acc'+ else do+ threadDelay 10_000 -- 10ms before checking again+ go acc++runTest :: String -> Assertion+runTest name = do+ let qfFile = testModulePath (name ++ ".qf")+ -- Remove any existing quickfix file+ qfExists <- Dir.doesFileExist qfFile+ when qfExists $ Dir.removeFile qfFile++ hDevNull <- openFile "/dev/null" WriteMode++ -- Use cabal repl to keep GHC alive long enough for background thread+ (Just ghciIn, Just ghciOut, _, h) <- Proc.createProcess+ (Proc.proc "cabal" ["repl", "test-modules:" ++ name])+ { Proc.std_in = Proc.CreatePipe+ , Proc.std_out = Proc.CreatePipe+ , Proc.std_err = Proc.UseHandle hDevNull+ }+ hSetBuffering ghciIn NoBuffering++ -- Wait for GHCi prompt+ waitForPrompt ghciOut++ -- Quit gracefully, ignoring errors if pipe is already closed+ void $ hPutStrLn ghciIn ":quit"+ void $ hClose ghciIn+ void $ Proc.waitForProcess h+ hClose hDevNull++ -- Check that quickfix file was created and has expected contents+ actualContents <- readFile qfFile+ expectedContents <- readFile $ qfFile ++ ".expected"+ assertEqual "Expected quickfix output" expectedContents actualContents++ -- Clean up+ Dir.removeFile qfFile++runTestWarningFix :: Assertion+runTestWarningFix = do+ let qfFile = testModulePath "WarningFix.qf"+ mod2File = testModulePath "WarningFix2.hs"+ mod2Broken = testModulePath "WarningFix2.hs.broken"+ mod2Fixed = testModulePath "WarningFix2.hs.fixed"++ -- Remove any existing quickfix file+ qfExists <- Dir.doesFileExist qfFile+ when qfExists $ Dir.removeFile qfFile++ -- Start with broken version (no type signature, has warning)+ Dir.copyFile mod2Broken mod2File++ hDevNull <- openFile "/dev/null" WriteMode++ -- Use cabal repl+ (Just ghciIn, Just ghciOut, _, h) <- Proc.createProcess+ (Proc.proc "cabal" ["repl", "test-modules:WarningFix"])+ { Proc.std_in = Proc.CreatePipe+ , Proc.std_out = Proc.CreatePipe+ , Proc.std_err = Proc.UseHandle hDevNull+ }+ hSetBuffering ghciIn NoBuffering++ -- Wait for GHCi prompt after initial compilation+ waitForPrompt ghciOut++ -- Check that quickfix file was created+ qfExists1 <- Dir.doesFileExist qfFile+ assertBool "Quickfix file should exist after initial compilation" qfExists1++ -- Check that quickfix file has error and warning+ actualContents1 <- readFile qfFile+ assertBool "Should have error and warning initially"+ (("error:" `isInfixOf` actualContents1) && ("warning:" `isInfixOf` actualContents1))++ -- Now fix the warning by copying fixed version+ Dir.copyFile mod2Fixed mod2File++ -- Reload in the repl+ void $ hPutStrLn ghciIn ":reload"++ -- Wait for GHCi prompt after reload+ waitForPrompt ghciOut++ -- Check that quickfix file now only has error, no warning+ actualContents2 <- readFile qfFile+ expectedContents <- readFile $ qfFile ++ ".expected"+ assertEqual "Expected only error after fix" expectedContents actualContents2++ -- Quit gracefully+ void $ hPutStrLn ghciIn ":quit"+ void $ hClose ghciIn+ void $ Proc.waitForProcess h+ hClose hDevNull++ -- Clean up+ Dir.removeFile qfFile+ Dir.removeFile mod2File