diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ghci-quickfix + +## 0.1.0.0 -- 2026-01-09 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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=`** + Specify the output file path for diagnostics. + Default: `errors.err` + Alternative: Set environment variable `GHCI_QUICKFIX_FILE=` + +- **`--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=:`** + 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=:` + +- **`--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. diff --git a/ghci-quickfix.cabal b/ghci-quickfix.cabal new file mode 100644 --- /dev/null +++ b/ghci-quickfix.cabal @@ -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 diff --git a/src/GhciQuickfix.hs b/src/GhciQuickfix.hs new file mode 100644 --- /dev/null +++ b/src/GhciQuickfix.hs @@ -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 diff --git a/src/GhciQuickfix/GhcFacade.hs b/src/GhciQuickfix/GhcFacade.hs new file mode 100644 --- /dev/null +++ b/src/GhciQuickfix/GhcFacade.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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