From e2e127511c6c13785818078714efa2da8c4c9ea1 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 15 Jun 2020 23:16:17 +0200 Subject: [PATCH 1/2] Add workaround for bad relative paths cabal repl switches current directory for subpackages of a project, resulting in error paths relative to some subdirectory. This confuses downstream tooling. Related cabal tickets are https://github.com/haskell/cabal/issues/5001 https://github.com/haskell/cabal/issues/1842 Gated behind the newly added flag --force-absolute-paths --- src/Ghcid.hs | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/src/Ghcid.hs b/src/Ghcid.hs index 9cf21c2..8a03256 100644 --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -8,6 +8,7 @@ import Control.Exception import System.IO.Error import Control.Applicative import Control.Monad.Extra +import Data.Char (isSpace) import Data.List.Extra import Data.Maybe import Data.Ord @@ -60,6 +61,7 @@ data Options = Options ,directory :: FilePath ,outputfile :: [FilePath] ,ignoreLoaded :: Bool + ,forceAbsolutePaths :: Bool ,poll :: Maybe Seconds ,max_messages :: Maybe Int ,color :: ColorMode @@ -99,6 +101,7 @@ options = cmdArgsMode $ Options ,directory = "." &= typDir &= name "C" &= help "Set the current directory" ,outputfile = [] &= typFile &= name "o" &= help "File to write the full output to" ,ignoreLoaded = False &= explicit &= name "ignore-loaded" &= help "Keep going if no files are loaded. Requires --reload to be set." + ,forceAbsolutePaths = False &= explicit &= name "force-absolute-paths" &= help "Workaround for bad relative paths with cabal repl - replaces paths in messages with absolute ones when writing to an output file" ,poll = Nothing &= typ "SECONDS" &= opt "0.1" &= explicit &= name "poll" &= help "Use polling every N seconds (defaults to using notifiers)" ,max_messages = Nothing &= name "n" &= help "Maximum number of messages to print" ,color = Auto &= name "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (defaults to when the terminal supports it)" @@ -290,7 +293,7 @@ runGhcid session waiter termSize termOutput opts@Options{..} = do outputFill currTime load evals msg = do load <- pure $ case load of Nothing -> [] - Just (loadedCount, msgs) -> prettyOutput currTime loadedCount (filter isMessage msgs) evals + Just (loadedCount, msgs) -> prettyOutput False currTime loadedCount (filter isMessage msgs) evals TermSize{..} <- termSize let wrap = concatMap (wordWrapE termWidth (termWidth `div` 5) . Esc) (msg, load, pad) <- @@ -384,7 +387,7 @@ runGhcid session waiter termSize termOutput opts@Options{..} = do if takeExtension file == ".json" then showJSON [("loaded",map jString loaded),("messages",map jMessage $ filter isMessage messages)] else - unlines $ map unescape $ prettyOutput currTime loadedCount (limitMessages ordMessages) evals + unlines $ map unescape $ prettyOutput forceAbsolutePaths currTime loadedCount (limitMessages ordMessages) evals when (null loaded && not ignoreLoaded) $ do putStrLn "No files loaded, nothing to wait for. Fix the last error and restart." exitFailure @@ -433,11 +436,29 @@ runGhcid session waiter termSize termOutput opts@Options{..} = do -- | Given an available height, and a set of messages to display, show them as best you can. -prettyOutput :: String -> Int -> [Load] -> [EvalResult] -> [String] -prettyOutput currTime loadedCount [] evals = +-- The boolean determines whether file paths in the warning/error messages +-- will be replaced by absolute paths provided in the loadFile field. +-- False ~ "keep the exact output from ghci" and +-- True ~ "paths will be replaced by absolute paths to help downstream tooling" +prettyOutput :: Bool -> String -> Int -> [Load] -> [EvalResult] -> [String] +prettyOutput _replacePaths currTime loadedCount [] evals = (allGoodMessage ++ " (" ++ show loadedCount ++ " module" ++ ['s' | loadedCount /= 1] ++ ", at " ++ currTime ++ ")") : concatMap printEval evals -prettyOutput _ _ xs evals = concatMap loadMessage xs ++ concatMap printEval evals +prettyOutput replacePaths _ _ xs evals = + messageLines ++ concatMap printEval evals + where + messageLines = + [ case l of + _ | not replacePaths -> l + "" -> l + c : _ | isSpace c -> l + _ -> if "hs:" `isInfixOf` l + then loadFile x ++ dropWhile (/= ':') l + else l + | x <- xs + , l <- loadMessage x + ] + printEval :: EvalResult -> [String] printEval (EvalResult file (line, col) msg result) = From 8c1e3ab02c253ad0dbaf9c3bbf226d8cbd716f9a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 27 Feb 2024 10:50:12 +0100 Subject: [PATCH 2/2] Add warning+error count --- src/Ghcid.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/Ghcid.hs b/src/Ghcid.hs index 8a03256..9b20b8b 100644 --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -289,11 +289,11 @@ runGhcid :: Session -> Waiter -> IO TermSize -> ([String] -> IO ()) -> Options - runGhcid session waiter termSize termOutput opts@Options{..} = do let limitMessages = maybe id (take . max 1) max_messages - let outputFill :: String -> Maybe (Int, [Load]) -> [EvalResult] -> [String] -> IO () + let outputFill :: String -> Maybe (Int, Int, Int, [Load]) -> [EvalResult] -> [String] -> IO () outputFill currTime load evals msg = do load <- pure $ case load of Nothing -> [] - Just (loadedCount, msgs) -> prettyOutput False currTime loadedCount (filter isMessage msgs) evals + Just (loadedCount, countErr, countWarn, msgs) -> prettyOutput False currTime loadedCount countErr countWarn (filter isMessage msgs) evals TermSize{..} <- termSize let wrap = concatMap (wordWrapE termWidth (termWidth `div` 5) . Esc) (msg, load, pad) <- @@ -373,21 +373,21 @@ runGhcid session waiter termSize termOutput opts@Options{..} = do -- order and restrict the messages -- nubOrdOn loadMessage because module cycles generate the same message at several different locations - ordMessages <- do + (ordMessages, countErr, countWarn) <- do let (msgError, msgWarn) = partition ((==) Error . loadSeverity) $ nubOrdOn loadMessage $ filter isMessage messages -- sort error messages by modtime, so newer edits cause the errors to float to the top - see #153 errTimes <- sequence [(x,) <$> getModTime x | x <- nubOrd $ map loadFile msgError] let f x = lookup (loadFile x) errTimes moduleSorted = sortOn (Down . f) msgError ++ msgWarn - pure $ (if reverse_errors then reverse else id) moduleSorted + pure $ (if reverse_errors then reverse moduleSorted else moduleSorted, length msgError, length msgWarn) - outputFill currTime (Just (loadedCount, ordMessages)) evals [test_message | isJust test] + outputFill currTime (Just (loadedCount, countErr, countWarn, ordMessages)) evals [test_message | isJust test] forM_ outputfile $ \file -> writeFile file $ if takeExtension file == ".json" then showJSON [("loaded",map jString loaded),("messages",map jMessage $ filter isMessage messages)] else - unlines $ map unescape $ prettyOutput forceAbsolutePaths currTime loadedCount (limitMessages ordMessages) evals + unlines $ map unescape $ prettyOutput forceAbsolutePaths currTime loadedCount countErr countWarn (limitMessages ordMessages) evals when (null loaded && not ignoreLoaded) $ do putStrLn "No files loaded, nothing to wait for. Fix the last error and restart." exitFailure @@ -440,12 +440,14 @@ runGhcid session waiter termSize termOutput opts@Options{..} = do -- will be replaced by absolute paths provided in the loadFile field. -- False ~ "keep the exact output from ghci" and -- True ~ "paths will be replaced by absolute paths to help downstream tooling" -prettyOutput :: Bool -> String -> Int -> [Load] -> [EvalResult] -> [String] -prettyOutput _replacePaths currTime loadedCount [] evals = +prettyOutput :: Bool -> String -> Int -> Int -> Int -> [Load] -> [EvalResult] -> [String] +prettyOutput _replacePaths currTime loadedCount _countErr _countWarn [] evals = (allGoodMessage ++ " (" ++ show loadedCount ++ " module" ++ ['s' | loadedCount /= 1] ++ ", at " ++ currTime ++ ")") : concatMap printEval evals -prettyOutput replacePaths _ _ xs evals = - messageLines ++ concatMap printEval evals +prettyOutput replacePaths _ _ countErr countWarn xs evals = + ["Total: " ++ show countErr ++ " errors, " ++ show countWarn ++ " warnings"] + ++ messageLines + ++ concatMap printEval evals where messageLines = [ case l of