From 7a58535ad25e64d8598ad4b23256004534a3728a Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Mon, 15 Jun 2020 23:16:17 +0200
Subject: [PATCH] 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 6cc13db..b1486f8 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
@@ -436,11 +439,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) =