ghcid 0.6.10 → 0.7
raw patch · 13 files changed
+794/−292 lines, 13 filesdep ~basedep ~extraPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, extra
API changes (from Hackage documentation)
+ Language.Haskell.Ghcid: LoadConfig :: FilePath -> Load
+ Language.Haskell.Ghcid: [loadFilePosEnd] :: Load -> (Int, Int)
+ Language.Haskell.Ghcid: showPaths :: Ghci -> IO (FilePath, [FilePath])
+ Language.Haskell.Ghcid: startGhciProcess :: CreateProcess -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
- Language.Haskell.Ghcid: Message :: Severity -> FilePath -> (Int, Int) -> [String] -> Load
+ Language.Haskell.Ghcid: Message :: Severity -> FilePath -> (Int, Int) -> (Int, Int) -> [String] -> Load
Files
- CHANGES.txt +28/−3
- README.md +15/−5
- ghcid.cabal +14/−10
- src/Ghcid.hs +134/−60
- src/Language/Haskell/Ghcid.hs +145/−118
- src/Language/Haskell/Ghcid/Escape.hs +108/−0
- src/Language/Haskell/Ghcid/Parser.hs +81/−30
- src/Language/Haskell/Ghcid/Types.hs +24/−11
- src/Language/Haskell/Ghcid/Util.hs +45/−16
- src/Session.hs +39/−17
- src/Test/Ghcid.hs +30/−5
- src/Test/Parser.hs +128/−15
- src/Test/Util.hs +3/−2
CHANGES.txt view
@@ -1,5 +1,30 @@-Changelog for ghcid+Changelog for ghcid (* = breaking change) +0.7, released 2018-04-18+ #153, show errors/warnings to freshly edited files first+ #153, set -j+ #154, improve Ctrl-C behaviour and process termination during startup+ Require extra-1.6.6+ Add --setup actions to send to ghci stdin on startup+ #152, make --output for a file ending .json produce JSON output+ Make module cycles generate well-formed Load messages+* Add loadFilePosEnd to Load+ If a command exits unexpectedly return a failing exit code+ #120, use absolute paths everywhere, in case ghci does a cd+ Add showPaths function to exercise ":show paths"+ #127, use Loaded GHCi configuration message to add .ghci restart+ #141, restart if .ghcid changes+ #151, make "All good" green+ #109, support OverloadedStrings and RebindableSyntax together+ Remove support for GHC 7.6+ #87, enable HSPEC colors if possible (POSIX only)+ #147, move some :set flags to the command line if possible+ #148, enable -ferror-spans by default+* #144, allow ANSI escape codes in loadMessage+ #144, use color GHC messages where possible+ #139, add --color=never to not show Bold output+ #142, add startGhciProcess which takes CreateProcess+ #146, add --max-messages=N to limit to N messages 0.6.10, released 2018-02-06 #96, make it work even if -fdiagnostics-color is active #130, pass -fno-it to reduce memory leaks@@ -51,7 +76,7 @@ #29, add interrupt function Add Data instances for the types Make stopGhci more effective, now kills the underlying process- Make startGhci take a function to write the buffer to+* Make startGhci take a function to write the buffer to 0.5.1, released 2016-03-02 #17, deal with recursive modules errors properly #50, use -fno-code when not running tests (about twice as fast)@@ -61,7 +86,7 @@ #43, work even if people use break-on-exception flags #42, make the first error a minimum of 5 lines 0.5, released 2015-06-20- Add an extra boolean argument to startGhci+* Add an extra boolean argument to startGhci Add the number of modules loaded after All good Print out messages until the prompt comes up #23, add arguments and change what commands get invoked
README.md view
@@ -6,7 +6,7 @@ ### Using it -Run `cabal update && cabal install ghcid` to install it as normal. Then run `ghcid --height=8 --topmost "--command=ghci Main.hs"`. The `height` is the number of lines you are going to resize your console window to (defaults to height of the console). The `topmost` is to make the window sit above all others, which only works on Windows. The `command` is how you start your project in `ghci`. If you omit `--command` then it will default to `stack ghci` if you have the `stack.yaml` file and `.stack-work` directory, default to `ghci` if you have a `.ghci` file in the current directory, and otherwise default to `cabal repl`.+Run `cabal update && cabal install ghcid` to install it as normal. Then run `ghcid "--command=ghci Main.hs"`. The `command` is how you start your project in `ghci`. If you omit `--command` then it will default to `stack ghci` if you have the `stack.yaml` file and `.stack-work` directory, default to `ghci` if you have a `.ghci` file in the current directory, and otherwise default to `cabal repl`. Personally, I always create a `.ghci` file at the root of all my projects, which usually [reads something like](https://github.com/ndmitchell/ghcid/blob/master/.ghci): @@ -14,7 +14,7 @@ :set -isrc :load Main -After that, resize your console and make it so you can see it while working in your editor. On Windows the console will automatically sit on top of all other windows. On Linux, you probably want to use your window manager to make it topmost or use a [tiling window manager](http://xmonad.org/).+After that, resize your console and make it so you can see it while working in your editor. On Windows you may wish to pass `--topmost` so the console will sit on top of all other windows. On Linux, you probably want to use your window manager to make it topmost or use a [tiling window manager](http://xmonad.org/). ### What you get @@ -33,13 +33,23 @@ ### Ghcid Integration -There are a few tools that integrate Ghcid into editors, see the [plugins](plugins/) folder for currently supported integrations.+There are a few plugins that integrate Ghcid into editors, notably: +* [VS Code](plugins/vscode/)+* [nvim](plugins/nvim/)+* [Emacs](plugins/emacs/)++And a blog article on using it:++* [Auto-reload threepenny-gui apps during development](https://binarin.ru/post/auto-reload-threepenny-gui/)+ ### FAQ * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). * _If I delete a file and put it back it gets stuck._ Yes, that's a [bug in GHCi](https://ghc.haskell.org/trac/ghc/ticket/9648). If you see GHCi getting confused just kill `ghcid` and start it again. * _I want to run my tests when files change._ You can pass any `ghci` expression with the `--test` flag, e.g. `--test=:main`, which will be run whenever the code is warning free (or pass `--warnings` for when the code is merely error free).-* _I want to run arbitrary commands when arbitrary files change._ This project reloads `ghci` when files loaded by `ghci` change. If you want a more general mechanism something like [Steel Overseer](https://github.com/schell/steeloverseer) will probably work better.-* _I want syntax highlighting in the error messages._ One option is to use Neovim or Emacs and run the terminal in a buffer whose file type is set to Haskell.+* _I want to run arbitrary commands when arbitrary files change._ This project reloads `ghci` when files loaded by `ghci` change. If you want a more general mechanism something like [Steel Overseer](https://github.com/schell/steeloverseer) or [Watchman](https://facebook.github.io/watchman/) will probably work better.+* _I want syntax highlighting in the error messages._ One option is to use Neovim or Emacs and run the terminal in a buffer whose file type is set to Haskell. Another option is to pipe `ghcid` through [source-highlight](https://www.gnu.org/software/src-highlite/) (`ghcid | source-highlight -s haskell -f esc`). * _I'm not seeing pattern matching warnings._ Ghcid automatically appends `-fno-code` to the command line, which makes the reload cycle about twice as fast. Unfortunately GHC 8.0 suffers from [bug 10600](https://ghc.haskell.org/trac/ghc/ticket/10600) which means `-fno-code` also disables pattern matching warnings. Until that GHC bug is fixed either accept no pattern match warnings or use `-c` to specify a command line to start `ghci` that doesn't include `-fno-code`.+* _I get "During interactive linking, GHCi couldn't find the following symbol"._ This problem is a manifestation of [GHC bug 8025](https://ghc.haskell.org/trac/ghc/ticket/8025), which is fixed in GHC 8.4 and above. Ghcid automatically appends `-fno-code` to the command line, but for older GHC's you can supress that with `--test "return ()"` (to add a fake test) or `-c "ghci ..."` to manually specify the command to run.+* _I only see source-spans or error messages on errors/warnings after the first load._ Due to limitations in `ghci`, these flags are only set _after_ the first load. If you want them to apply from the start, pass them on the command line to `ghci` with something like `-c "ghci -ferror-spans -fdiagnostics-color=always".
ghcid.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: ghcid-version: 0.6.10+version: 0.7 license: BSD3 license-file: LICENSE category: Development@@ -13,7 +13,7 @@ Either \"GHCi as a daemon\" or \"GHC + a bit of an IDE\". A very simple Haskell development tool which shows you the errors in your project and updates them whenever you save. Run @ghcid --topmost --command=ghci@, where @--topmost@ makes the window on top of all others (Windows only) and @--command@ is the command to start GHCi on your project (defaults to @ghci@ if you have a @.ghci@ file, or else to @cabal repl@). homepage: https://github.com/ndmitchell/ghcid#readme bug-reports: https://github.com/ndmitchell/ghcid/issues-tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4 extra-doc-files: CHANGES.txt README.md@@ -26,20 +26,22 @@ hs-source-dirs: src default-language: Haskell2010 build-depends:- base >= 4,+ base >= 4.7 && < 5, filepath, time >= 1.5, directory >= 1.2,- extra >= 1.2,+ extra >= 1.6.6, process >= 1.1,+ ansi-terminal, cmdargs >= 0.10 exposed-modules: Language.Haskell.Ghcid other-modules: Paths_ghcid- Language.Haskell.Ghcid.Types+ Language.Haskell.Ghcid.Escape Language.Haskell.Ghcid.Parser+ Language.Haskell.Ghcid.Types Language.Haskell.Ghcid.Util executable ghcid@@ -48,13 +50,13 @@ ghc-options: -main-is Ghcid.main -threaded main-is: Ghcid.hs build-depends:- base == 4.*,+ base >= 4.7 && < 5, filepath, time >= 1.5, directory >= 1.2, containers, fsnotify,- extra >= 1.2,+ extra >= 1.6.6, process >= 1.1, cmdargs >= 0.10, ansi-terminal,@@ -64,9 +66,10 @@ else build-depends: unix other-modules:- Language.Haskell.Ghcid.Types+ Language.Haskell.Ghcid.Escape Language.Haskell.Ghcid.Parser Language.Haskell.Ghcid.Terminal+ Language.Haskell.Ghcid.Types Language.Haskell.Ghcid.Util Language.Haskell.Ghcid Paths_ghcid@@ -80,14 +83,14 @@ ghc-options: -rtsopts -main-is Test.main -threaded -with-rtsopts=-K1K default-language: Haskell2010 build-depends:- base >= 4,+ base >= 4.7 && < 5, filepath, time >= 1.5, directory >= 1.2, process, containers, fsnotify,- extra >= 1.2,+ extra >= 1.6.6, ansi-terminal, terminal-size >= 0.3, cmdargs,@@ -100,6 +103,7 @@ other-modules: Ghcid Language.Haskell.Ghcid+ Language.Haskell.Ghcid.Escape Language.Haskell.Ghcid.Parser Language.Haskell.Ghcid.Terminal Language.Haskell.Ghcid.Types
src/Ghcid.hs view
@@ -9,6 +9,7 @@ import Control.Monad.Extra import Data.List.Extra import Data.Maybe+import Data.Ord import Data.Tuple.Extra import Data.Version import Session@@ -24,6 +25,7 @@ import System.IO.Extra import Paths_ghcid+import Language.Haskell.Ghcid.Escape import Language.Haskell.Ghcid.Terminal import Language.Haskell.Ghcid.Util import Language.Haskell.Ghcid.Types@@ -51,12 +53,22 @@ ,outputfile :: [FilePath] ,ignoreLoaded :: Bool ,poll :: Maybe Seconds+ ,max_messages :: Maybe Int+ ,color :: ColorMode+ ,setup :: [String] } deriving (Data,Typeable,Show) +-- | When to colour terminal output.+data ColorMode+ = Never -- ^ Terminal output will never be coloured.+ | Always -- ^ Terminal output will always be coloured.+ | Auto -- ^ Terminal output will be coloured if $TERM and stdout appear to support it.+ deriving (Show, Typeable, Data)+ options :: Mode (CmdArgs Options) options = cmdArgsMode $ Options- {command = "" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)"+ {command = "" &= name "c" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)" ,arguments = [] &= args &= typ "MODULE" ,test = [] &= name "T" &= typ "EXPR" &= help "Command to run after successful loading" ,warnings = False &= name "W" &= help "Allow tests to run even with warnings"@@ -72,6 +84,9 @@ ,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." ,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)"+ ,setup = [] &= name "setup" &= typ "COMMAND" &= help "Setup commands to pass to ghci on stdin, usually :set <something>" } &= verbosity &= program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version) @@ -103,25 +118,28 @@ autoOptions o@Options{..} | command /= "" = return $ f [command] [] | otherwise = do+ curdir <- getCurrentDirectory files <- getDirectoryContents "." -- use unsafePerformIO to get nicer pattern matching for logic (read-only operations)- let isStack dir = flip catchIOError (const $ return False) $- doesFileExist (dir </> "stack.yaml") &&^ doesDirectoryExist (dir </> ".stack-work")- stack <- isStack "." ||^ isStack ".." -- stack file might be parent, see #62+ let findStack dir = flip catchIOError (const $ return Nothing) $ do+ let yaml = dir </> "stack.yaml"+ b <- doesFileExist yaml &&^ doesDirectoryExist (dir </> ".stack-work")+ return $ if b then Just yaml else Nothing+ stack <- firstJustM findStack [".",".."] -- stack file might be parent, see #62 - let cabal = filter ((==) ".cabal" . takeExtension) files- let opts = ["-fno-code" | null test]+ let cabal = map (curdir </>) $ filter ((==) ".cabal" . takeExtension) files+ let opts = ["-fno-code" | null test] ++ ghciFlagsRequired ++ ghciFlagsUseful return $ case () of- _ | stack ->+ _ | Just stack <- stack -> let flags = if null arguments then "stack ghci --test" : ["--no-load" | ".ghci" `elem` files] ++ map ("--ghci-options=" ++) opts else "stack exec --test -- ghci" : opts- in f flags $ "stack.yaml":cabal- | ".ghci" `elem` files -> f ("ghci":opts) [".ghci"]+ in f flags $ stack:cabal+ | ".ghci" `elem` files -> f ("ghci":opts) [curdir </> ".ghci"] | cabal /= [] -> f (if null arguments then "cabal repl":map ("--ghc-options=" ++) opts else "cabal exec -- ghci":opts) cabal | otherwise -> f ("ghci":opts) [] where@@ -142,69 +160,91 @@ -- | Like 'main', but run with a fake terminal for testing-mainWithTerminal :: IO (Int,Int) -> ([(Style,String)] -> IO ()) -> IO ()-mainWithTerminal termSize termOutput = withWindowIcon $ withSession $ \session -> do- -- On certain Cygwin terminals stdout defaults to BlockBuffering- hSetBuffering stdout LineBuffering- hSetBuffering stderr NoBuffering- opts <- withGhcidArgs $ cmdArgsRun options- withCurrentDirectory (directory opts) $ do- opts <- autoOptions opts- opts <- return $ opts{restart = nubOrd $ restart opts, reload = nubOrd $ reload opts}- when (topmost opts) terminalTopmost+mainWithTerminal :: IO (Int,Int) -> ([String] -> IO ()) -> IO ()+mainWithTerminal termSize termOutput =+ handle (\(UnexpectedExit cmd _) -> do putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly"; exitFailure) $+ forever $ withWindowIcon $ withSession $ \session -> do+ setVerbosity Normal -- undo any --verbose flags - termSize <- return $ case (width opts, height opts) of- (Just w, Just h) -> return (w,h)- (w, h) -> do- term <- termSize- -- if we write to the final column of the window then it wraps automatically- -- so putStrLn width 'x' uses up two lines- return (fromMaybe (pred $ fst term) w, fromMaybe (snd term) h)+ -- On certain Cygwin terminals stdout defaults to BlockBuffering+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr NoBuffering+ origDir <- getCurrentDirectory+ opts <- withGhcidArgs $ cmdArgsRun options+ withCurrentDirectory (directory opts) $ do+ opts <- autoOptions opts+ opts <- return $ opts{restart = nubOrd $ (origDir </> ".ghcid") : restart opts, reload = nubOrd $ reload opts}+ when (topmost opts) terminalTopmost - maybe withWaiterNotify withWaiterPoll (poll opts) $ \waiter ->- handle (\(UnexpectedExit cmd _) -> putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly") $- runGhcid session waiter termSize termOutput opts+ termSize <- return $ case (width opts, height opts) of+ (Just w, Just h) -> return (w,h)+ (w, h) -> do+ term <- termSize+ -- if we write to the final column of the window then it wraps automatically+ -- so putStrLn width 'x' uses up two lines+ return (fromMaybe (pred $ fst term) w, fromMaybe (snd term) h) + restyle <- do+ useStyle <- case color opts of+ Always -> return True+ Never -> return False+ Auto -> hSupportsANSI stdout+ when useStyle $ do+ h <- lookupEnv "HSPEC_OPTIONS"+ when (isNothing h) $ setEnv "HSPEC_OPTIONS" "--color" -- see #87+ return $ if useStyle then id else map unescape + maybe withWaiterNotify withWaiterPoll (poll opts) $ \waiter ->+ runGhcid session waiter termSize (termOutput . restyle) opts ++ main :: IO () main = mainWithTerminal termSize termOutput where termSize = maybe (80, 8) (Term.width &&& Term.height) <$> Term.size termOutput xs = do- outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do- when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity]- putStr $ concatMap ((:) '\n' . snd) x- when (s == Bold) $ setSGR []+ outStr $ concatMap ('\n':) xs hFlush stdout -- must flush, since we don't finish with a newline -data Style = Plain | Bold deriving Eq-+data Continue = Continue -runGhcid :: Session -> Waiter -> IO (Int,Int) -> ([(Style,String)] -> IO ()) -> Options -> IO ()+-- If we return successfully, we restart the whole process+-- Use Continue not () so that inadvertant exits don't restart+runGhcid :: Session -> Waiter -> IO (Int,Int) -> ([String] -> IO ()) -> Options -> IO Continue runGhcid session waiter termSize termOutput opts@Options{..} = do- let outputFill :: Maybe (Int, [Load]) -> [String] -> IO ()- outputFill load msg = do+ let outputFill :: String -> Maybe (Int, [Load]) -> [String] -> IO ()+ outputFill currTime load msg = do (width, height) <- termSize let n = height - length msg- currTime <- getShortTime- load <- return $ take (if isJust load then n else 0) $ prettyOutput currTime (maybe 0 fst load)- [ m{loadMessage = concatMap (chunksOfWord width (width `div` 5)) $ loadMessage m}+ load <- return $ take (if isJust load then n else 0) $ prettyOutput max_messages currTime (maybe 0 fst load)+ [ m{loadMessage = map fromEsc $ concatMap (chunksOfWordE width (width `div` 5) . Esc) $ loadMessage m} | m@Message{} <- maybe [] snd load]- termOutput $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"")+ termOutput $ load ++ msg ++ replicate (height - (length load + length msg)) "" when (ignoreLoaded && null reload) $ do putStrLn "--reload must be set when using --ignore-loaded" exitFailure + nextWait <- waitFiles waiter+ (messages, loaded) <- sessionStart session command $+ map (":set " ++) (ghciFlagsUseful ++ ghciFlagsUsefulVersioned) ++ setup++ when (null loaded && not ignoreLoaded) $ do+ putStrLn $ "\nNo files loaded, GHCi is not working properly.\nCommand: " ++ command+ exitFailure++ restart <- return $ nubOrd $ restart ++ [x | LoadConfig x <- messages]+ -- Note that we capture restarting items at this point, not before invoking the command+ -- The reason is some restart items may be generated by the command itself restartTimes <- mapM getModTime restart curdir <- getCurrentDirectory- currTime <- getShortTime -- fire, given a waiter, the messages/loaded let fire nextWait (messages, loaded) = do+ currTime <- getShortTime let loadedCount = length loaded whenLoud $ do outStrLn $ "%MESSAGES: " ++ show messages@@ -219,7 +259,7 @@ unless no_title $ setWindowIcon $ if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK - let updateTitle extra = unless no_title $ setTitle $+ let updateTitle extra = unless no_title $ setTitle $ unescape $ let f n msg = if n == 0 then "" else show n ++ " " ++ msg ++ ['s' | n > 1] in (if countErrors == 0 && countWarnings == 0 then allGoodMessage ++ ", at " ++ currTime else f countErrors "error" ++ (if countErrors > 0 && countWarnings > 0 then ", " else "") ++ f countWarnings "warning") ++@@ -227,9 +267,23 @@ (if null project then takeFileName curdir else project) updateTitle $ if isJust test then "(running test)" else ""- outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test]++ -- order and restrict the messages+ -- nubOrdOn loadMessage because module cycles generate the same message at several different locations+ ordMessages <- 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+ return $ sortOn (Down . f) msgError ++ msgWarn++ outputFill currTime (Just (loadedCount, ordMessages)) ["Running test..." | isJust test] forM_ outputfile $ \file ->- writeFile file $ unlines $ map snd $ prettyOutput currTime loadedCount $ filter isMessage messages+ writeFile file $+ if takeExtension file == ".json" then+ showJSON [("loaded",map jString loaded),("messages",map jMessage $ filter isMessage messages)]+ else+ unlines $ map unescape $ prettyOutput max_messages currTime loadedCount ordMessages when (null loaded && not ignoreLoaded) $ do putStrLn "No files loaded, nothing to wait for. Fix the last error and restart." exitFailure@@ -246,25 +300,45 @@ whenNormal $ outStrLn "\n...done" reason <- nextWait $ restart ++ reload ++ loaded- unless no_status $ outputFill Nothing $ "Reloading..." : map (" " ++) reason+ whenLoud $ outStrLn $ "%RELOADING: " ++ unwords reason restartTimes2 <- mapM getModTime restart- if restartTimes == restartTimes2 then do+ let restartChanged = [s | (False, s) <- zip (zipWith (==) restartTimes restartTimes2) restart]+ currTime <- getShortTime+ if not $ null restartChanged then do+ -- exit cleanly, since the whole thing is wrapped in a forever+ unless no_status $ outputFill currTime Nothing $ "Restarting..." : map (" " ++) restartChanged+ return Continue+ else do+ unless no_status $ outputFill currTime Nothing $ "Reloading..." : map (" " ++) reason nextWait <- waitFiles waiter fire nextWait =<< sessionReload session- else- runGhcid session waiter termSize termOutput opts - nextWait <- waitFiles waiter- (messages, loaded) <- sessionStart session command- when (null loaded && not ignoreLoaded) $ do- putStrLn $ "\nNo files loaded, GHCi is not working properly.\nCommand: " ++ command- exitFailure fire nextWait (messages, loaded) -- | Given an available height, and a set of messages to display, show them as best you can.-prettyOutput :: String -> Int -> [Load] -> [(Style,String)]-prettyOutput currTime loaded [] = [(Plain,allGoodMessage ++ " (" ++ show loaded ++ " module" ++ ['s' | loaded /= 1] ++ ", at " ++ currTime ++ ")")]-prettyOutput _ loaded xs = concat $ msg1:msgs- where (err, warn) = partition ((==) Error . loadSeverity) xs- msg1:msgs = map (map (Bold,) . loadMessage) err ++ map (map (Plain,) . loadMessage) warn+prettyOutput :: Maybe Int -> String -> Int -> [Load] -> [String]+prettyOutput _ currTime loaded [] =+ [allGoodMessage ++ " (" ++ show loaded ++ " module" ++ ['s' | loaded /= 1] ++ ", at " ++ currTime ++ ")"]+prettyOutput maxMsgs _ loaded xs = concat $ maybe id take maxMsgs $ map loadMessage xs+++showJSON :: [(String, [String])] -> String+showJSON xs = unlines $ concat $+ [ ((if i == 0 then "{" else ",") ++ jString a ++ ":") :+ [" " ++ (if j == 0 then "[" else ",") ++ b | (j,b) <- zipFrom 0 bs] +++ [if null bs then " []" else " ]"]+ | (i,(a,bs)) <- zipFrom 0 xs] +++ [["}"]]++jString x = "\"" ++ escapeJSON x ++ "\""++jMessage Message{..} = jDict $+ [("severity",jString $ show loadSeverity)+ ,("file",jString loadFile)] +++ [("start",pair loadFilePos) | loadFilePos /= (0,0)] +++ [("end", pair loadFilePosEnd) | loadFilePos /= loadFilePosEnd] +++ [("message", jString $ intercalate "\n" loadMessage)]+ where pair (a,b) = "[" ++ show a ++ "," ++ show b ++ "]"++jDict xs = "{" ++ intercalate ", " [jString a ++ ":" ++ b | (a,b) <- xs] ++ "}"
src/Language/Haskell/Ghcid.hs view
@@ -4,8 +4,8 @@ module Language.Haskell.Ghcid( Ghci, GhciError(..), Stream(..), Load(..), Severity(..),- startGhci, stopGhci, interrupt, process, execStream,- showModules, reload, exec, quit+ startGhci, startGhciProcess, stopGhci, interrupt, process,+ execStream, showModules, showPaths, reload, exec, quit ) where import System.IO@@ -45,137 +45,161 @@ instance Eq Ghci where a == b = ghciUnique a == ghciUnique b --- | Start GHCi, returning a function to perform further operation, as well as the result of the initial loading.++withCreateProc proc f = do+ let undo (_, _, _, proc) = ignored $ terminateProcess proc+ bracketOnError (createProcess proc) undo $ \(a,b,c,d) -> f a b c d++-- | Start GHCi by running the described process, returning the result of the initial loading. -- If you do not call 'stopGhci' then the underlying process may be leaked. -- The callback will be given the messages produced while loading, useful if invoking something like "cabal repl" -- which might compile dependent packages before really loading.-startGhci :: String -> Maybe FilePath -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])-startGhci cmd directory echo0 = do- (Just inp, Just out, Just err, ghciProcess) <-- createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, cwd=directory, create_group=True}+--+-- To create a 'CreateProcess' use the functions in "System.Process", particularly+-- 'System.Process.shell' and 'System.Process.proc'.+--+-- @since 0.6.11+startGhciProcess :: CreateProcess -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])+startGhciProcess process echo0 = do+ let proc = process{std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, create_group=True}+ withCreateProc proc $ \(Just inp) (Just out) (Just err) ghciProcess -> do - hSetBuffering out LineBuffering- hSetBuffering err LineBuffering- hSetBuffering inp LineBuffering- let writeInp x = do- whenLoud $ outStrLn $ "%STDIN: " ++ x- hPutStrLn inp x+ hSetBuffering out LineBuffering+ hSetBuffering err LineBuffering+ hSetBuffering inp LineBuffering+ let writeInp x = do+ whenLoud $ outStrLn $ "%STDIN: " ++ x+ hPutStrLn inp x - -- Some programs (e.g. stack) might use stdin before starting ghci (see #57)- -- Send them an empty line- hPutStrLn inp ""+ -- Some programs (e.g. stack) might use stdin before starting ghci (see #57)+ -- Send them an empty line+ hPutStrLn inp "" - -- I'd like the GHCi prompt to go away, but that's not possible, so I set it to a special- -- string and filter that out.- let ghcid_prefix = "#~GHCID-START~#"- let removePrefix = dropPrefixRepeatedly ghcid_prefix+ -- I'd like the GHCi prompt to go away, but that's not possible, so I set it to a special+ -- string and filter that out.+ let ghcid_prefix = "#~GHCID-START~#"+ let removePrefix = dropPrefixRepeatedly ghcid_prefix - -- At various points I need to ensure everything the user is waiting for has completed- -- So I send messages on stdout/stderr and wait for them to arrive- syncCount <- newVar 0- let syncReplay = do- i <- readVar syncCount- let msg = "#~GHCID-FINISH-" ++ show i ++ "~#"- writeInp $ "INTERNAL_GHCID.putStrLn " ++ show msg ++ "\n" ++- "INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ show msg- return $ isInfixOf msg- let syncFresh = do- modifyVar_ syncCount $ return . succ- syncReplay+ -- At various points I need to ensure everything the user is waiting for has completed+ -- So I send messages on stdout/stderr and wait for them to arrive+ syncCount <- newVar 0+ let syncReplay = do+ i <- readVar syncCount+ -- useful to avoid overloaded strings by showing the ['a','b','c'] form, see #109+ let showStr xs = "[" ++ intercalate "," (map show xs) ++ "]"+ let msg = "#~GHCID-FINISH-" ++ show i ++ "~#"+ writeInp $ "INTERNAL_GHCID.putStrLn " ++ showStr msg ++ "\n" +++ "INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ showStr msg+ return $ isInfixOf msg+ let syncFresh = do+ modifyVar_ syncCount $ return . succ+ syncReplay - -- Consume from a stream until EOF (return Nothing) or some predicate returns Just- let consume :: Stream -> (String -> IO (Maybe a)) -> IO (Maybe a)- consume name finish = do- let h = if name == Stdout then out else err- fix $ \rec -> do- el <- tryBool isEOFError $ hGetLine h- case el of- Left _ -> return Nothing- Right l -> do- whenLoud $ outStrLn $ "%" ++ upper (show name) ++ ": " ++ l- res <- finish $ removePrefix l- case res of- Nothing -> rec- Just a -> return $ Just a+ -- Consume from a stream until EOF (return Nothing) or some predicate returns Just+ let consume :: Stream -> (String -> IO (Maybe a)) -> IO (Maybe a)+ consume name finish = do+ let h = if name == Stdout then out else err+ fix $ \rec -> do+ el <- tryBool isEOFError $ hGetLine h+ case el of+ Left _ -> return Nothing+ Right l -> do+ whenLoud $ outStrLn $ "%" ++ upper (show name) ++ ": " ++ l+ res <- finish $ removePrefix l+ case res of+ Nothing -> rec+ Just a -> return $ Just a - let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a)- consume2 msg finish = do- res1 <- onceFork $ consume Stdout (finish Stdout)- res2 <- consume Stderr (finish Stderr)- res1 <- res1- case liftM2 (,) res1 res2 of- Nothing -> throwIO $ UnexpectedExit cmd msg- Just v -> return v+ let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a)+ consume2 msg finish = do+ -- fetch the operations in different threads as hGetLine may block+ -- and can't be aborted by async exceptions, see #154+ res1 <- onceFork $ consume Stdout (finish Stdout)+ res2 <- onceFork $ consume Stderr (finish Stderr)+ res1 <- res1+ res2 <- res2+ case liftM2 (,) res1 res2 of+ Nothing -> case cmdspec process of+ ShellCommand cmd -> throwIO $ UnexpectedExit cmd msg+ RawCommand exe args -> throwIO $ UnexpectedExit (unwords (exe:args)) msg+ Just v -> return v - -- held while interrupting, and briefly held when starting an exec- -- ensures exec values queue up behind an ongoing interrupt and no two interrupts run at once- isInterrupting <- newLock+ -- held while interrupting, and briefly held when starting an exec+ -- ensures exec values queue up behind an ongoing interrupt and no two interrupts run at once+ isInterrupting <- newLock - -- is anyone running running an exec statement, ensure only one person talks to ghci at a time- isRunning <- newLock+ -- is anyone running running an exec statement, ensure only one person talks to ghci at a time+ isRunning <- newLock - let ghciExec command echo = do- withLock isInterrupting $ return ()- res <- withLockTry isRunning $ do- writeInp command- stop <- syncFresh- void $ consume2 command $ \strm s ->- if stop s then return $ Just () else do echo strm s; return Nothing- when (isNothing res) $- fail "Ghcid.exec, computation is already running, must be used single-threaded"+ let ghciExec command echo = do+ withLock isInterrupting $ return ()+ res <- withLockTry isRunning $ do+ writeInp command+ stop <- syncFresh+ void $ consume2 command $ \strm s ->+ if stop s then return $ Just () else do echo strm s; return Nothing+ when (isNothing res) $+ fail "Ghcid.exec, computation is already running, must be used single-threaded" - let ghciInterrupt = withLock isInterrupting $- whenM (fmap isNothing $ withLockTry isRunning $ return ()) $ do- whenLoud $ outStrLn "%INTERRUPT"- interruptProcessGroupOf ghciProcess- -- let the person running ghciExec finish, since their sync messages- -- may have been the ones that got interrupted- syncReplay- -- now wait for the person doing ghciExec to have actually left the lock- withLock isRunning $ return ()- -- there may have been two syncs sent, so now do a fresh sync to clear everything- stop <- syncFresh- void $ consume2 "Interrupt" $ \_ s -> return $ if stop s then Just () else Nothing+ let ghciInterrupt = withLock isInterrupting $+ whenM (fmap isNothing $ withLockTry isRunning $ return ()) $ do+ whenLoud $ outStrLn "%INTERRUPT"+ interruptProcessGroupOf ghciProcess+ -- let the person running ghciExec finish, since their sync messages+ -- may have been the ones that got interrupted+ syncReplay+ -- now wait for the person doing ghciExec to have actually left the lock+ withLock isRunning $ return ()+ -- there may have been two syncs sent, so now do a fresh sync to clear everything+ stop <- syncFresh+ void $ consume2 "Interrupt" $ \_ s -> return $ if stop s then Just () else Nothing - ghciUnique <- newUnique- let ghci = Ghci{..}+ ghciUnique <- newUnique+ let ghci = Ghci{..} - -- Now wait for 'GHCi, version' to appear before sending anything real, required for #57- stdout <- newIORef []- stderr <- newIORef []- sync <- newIORef $ const False- consume2 "" $ \strm s -> do- stop <- readIORef sync- if stop s then- return $ Just ()- else do- -- there may be some initial prompts on stdout before I set the prompt properly- s <- return $ maybe s (removePrefix . snd) $ stripInfix ghcid_prefix s- whenLoud $ outStrLn $ "%STDOUT2: " ++ s- modifyIORef (if strm == Stdout then stdout else stderr) (s:)- when ("GHCi, version " `isPrefixOf` s) $ do- -- the thing before me may have done its own Haskell compiling- writeIORef stdout []- writeIORef stderr []- writeInp "import qualified System.IO as INTERNAL_GHCID"- writeInp $ ":set prompt " ++ ghcid_prefix- writeInp ":set -v1 -fno-break-on-exception -fno-break-on-error" -- see #43 and #110- writeInp ":set -fdiagnostics-color=never" -- see #96- writeInp ":set -fno-hide-source-paths" -- see #132- -- only works with GHC 8.2 and above, but failing isn't harmful- -- writeInp ":set -fno-it" -- see #130- -- only works with GHC 8.6 and above, but failing isn't harmful- writeIORef sync =<< syncFresh- echo0 strm s- return Nothing- r1 <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)- -- see #132, if hide-source-paths was turned on the modules didn't get printed out properly- -- so try a showModules to capture the information again- r2 <- if any isLoading r1 then return [] else map (uncurry Loading) <$> showModules ghci- execStream ghci "" echo0- return (ghci, r1 ++ r2)+ -- Now wait for 'GHCi, version' to appear before sending anything real, required for #57+ stdout <- newIORef []+ stderr <- newIORef []+ sync <- newIORef $ const False+ consume2 "" $ \strm s -> do+ stop <- readIORef sync+ if stop s then+ return $ Just ()+ else do+ -- there may be some initial prompts on stdout before I set the prompt properly+ s <- return $ maybe s (removePrefix . snd) $ stripInfix ghcid_prefix s+ whenLoud $ outStrLn $ "%STDOUT2: " ++ s+ modifyIORef (if strm == Stdout then stdout else stderr) (s:)+ when ("GHCi, version " `isPrefixOf` s) $ do+ -- the thing before me may have done its own Haskell compiling+ writeIORef stdout []+ writeIORef stderr []+ writeInp "import qualified System.IO as INTERNAL_GHCID"+ writeInp $ ":set prompt " ++ ghcid_prefix + -- failure isn't harmful, so do them one-by-one+ forM_ (ghciFlagsRequired ++ ghciFlagsRequiredVersioned) $ \flag ->+ writeInp $ ":set " ++ flag+ writeIORef sync =<< syncFresh+ echo0 strm s+ return Nothing+ r1 <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)+ -- see #132, if hide-source-paths was turned on the modules didn't get printed out properly+ -- so try a showModules to capture the information again+ r2 <- if any isLoading r1 then return [] else map (uncurry Loading) <$> showModules ghci+ execStream ghci "" echo0+ return (ghci, r1 ++ r2) ++-- | Start GHCi by running the given shell command, a helper around 'startGhciProcess'.+startGhci+ :: String -- ^ Shell command+ -> Maybe FilePath -- ^ Working directory+ -> (Stream -> String -> IO ()) -- ^ Output callback+ -> IO (Ghci, [Load])+startGhci cmd directory = startGhciProcess (shell cmd){cwd=directory}++ -- | Execute a command, calling a callback on each response. -- The callback will be called single threaded. execStream :: Ghci -> String -> (Stream -> String -> IO ()) -> IO ()@@ -213,6 +237,10 @@ showModules :: Ghci -> IO [(String,FilePath)] showModules ghci = parseShowModules <$> exec ghci ":show modules" +-- | Return the current working directory, and a list of module import paths+showPaths :: Ghci -> IO (FilePath, [FilePath])+showPaths ghci = parseShowPaths <$> exec ghci ":show paths"+ -- | Perform a reload, list the messages that reload generated. reload :: Ghci -> IO [Load] reload ghci = parseLoad <$> exec ghci ":reload"@@ -224,8 +252,7 @@ handle (\UnexpectedExit{} -> return ()) $ void $ exec ghci ":quit" -- Be aware that waitForProcess has a race condition, see https://github.com/haskell/process/issues/46. -- Therefore just ignore the exception anyway, its probably already terminated.- ignore $- void $ waitForProcess $ process ghci+ ignored $ void $ waitForProcess $ process ghci -- | Stop GHCi. Attempts to interrupt and execute @:quit:@, but if that doesn't complete
+ src/Language/Haskell/Ghcid/Escape.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE PatternGuards #-}++-- | Module for dealing with escape codes+module Language.Haskell.Ghcid.Escape(+ Esc(..), unescape,+ stripInfixE, stripPrefixE, isPrefixOfE, spanE, trimStartE, unwordsE, unescapeE,+ chunksOfWordE+ ) where++import Data.Char+import Data.Either.Extra+import Data.List.Extra+import Data.Maybe+import Data.Tuple.Extra+import Control.Applicative+import Prelude+++-- A string with escape characters in it+newtype Esc = Esc {fromEsc :: String}+ deriving (Eq,Show)++app (Esc x) (Esc y) = Esc $ x ++ y++unesc :: Esc -> Maybe (Either Esc Char, Esc)+unesc (Esc ('\ESC':xs)) | (pre,'m':post) <- break (== 'm') xs = Just (Left $ Esc $ '\ESC':pre++"m", Esc post)+unesc (Esc (x:xs)) = Just (Right x, Esc xs)+unesc (Esc []) = Nothing++explode :: Esc -> [Either Esc Char]+explode = unfoldr unesc++implode :: [Either Esc Char] -> Esc+implode = Esc . concatMap (either fromEsc return)++unescape :: String -> String+unescape = unescapeE . Esc++-- | Remove all escape characters in a string+unescapeE :: Esc -> String+unescapeE = rights . explode++stripPrefixE :: String -> Esc -> Maybe Esc+stripPrefixE [] e = Just e+stripPrefixE (x:xs) e = case unesc e of+ Just (Left code, rest) -> app code <$> stripPrefixE (x:xs) rest+ Just (Right y, rest) | y == x -> stripPrefixE xs rest+ _ -> Nothing++stripInfixE :: String -> Esc -> Maybe (Esc, Esc)+stripInfixE needle haystack | Just rest <- stripPrefixE needle haystack = Just (Esc [], rest)+stripInfixE needle e = case unesc e of+ Nothing -> Nothing+ Just (x,xs) -> first (app $ fromEither $ fmap (Esc . return) x) <$> stripInfixE needle xs+++spanE, breakE :: (Char -> Bool) -> Esc -> (Esc, Esc)+breakE f = spanE (not . f)+spanE f e = case unesc e of+ Nothing -> (Esc "", Esc "")+ Just (Left e, rest) -> first (app e) $ spanE f rest+ Just (Right c, rest) | f c -> first (app $ Esc [c]) $ spanE f rest+ | otherwise -> (Esc "", e)++isPrefixOfE :: String -> Esc -> Bool+isPrefixOfE x y = isJust $ stripPrefixE x y++trimStartE :: Esc -> Esc+trimStartE e = case unesc e of+ Nothing -> Esc ""+ Just (Left code, rest) -> app code $ trimStartE rest+ Just (Right c, rest) | isSpace c -> trimStartE rest+ | otherwise -> e++unwordsE :: [Esc] -> Esc+unwordsE = Esc . unwords . map fromEsc+++repeatedlyE :: (Esc -> (b, Esc)) -> Esc -> [b]+repeatedlyE f (Esc []) = []+repeatedlyE f as = b : repeatedlyE f as'+ where (b, as') = f as++splitAtE :: Int -> Esc -> (Esc, Esc)+splitAtE i e = case unesc e of+ _ | i <= 0 -> (Esc "", e)+ Nothing -> (e, e)+ Just (Left code, rest) -> first (app code) $ splitAtE i rest+ Just (Right c, rest) -> first (app $ Esc [c]) $ splitAtE (i-1) rest++reverseE :: Esc -> Esc+reverseE = implode . reverse . explode++breakEndE :: (Char -> Bool) -> Esc -> (Esc, Esc)+breakEndE f = swap . both reverseE . breakE f . reverseE+++lengthE :: Esc -> Int+lengthE = length . unescapeE++-- | Like chunksOf, but deal with words up to some gap.+-- Flows onto a subsequent line if less than N characters end up being empty.+chunksOfWordE :: Int -> Int -> Esc -> [Esc]+chunksOfWordE mx gap = repeatedlyE $ \x ->+ let (a,b) = splitAtE mx x in+ if b == Esc "" then (a, Esc "") else+ let (a1,a2) = breakEndE isSpace a in+ if lengthE a2 <= gap then (a1, app a2 b) else (a, trimStartE b)
src/Language/Haskell/Ghcid/Parser.hs view
@@ -1,70 +1,121 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} -- | Parses the output from GHCi module Language.Haskell.Ghcid.Parser(- parseShowModules, parseLoad+ parseShowModules, parseShowPaths, parseLoad ) where import System.FilePath import Data.Char import Data.List.Extra+import Data.Maybe+import Text.Read import Data.Tuple.Extra import Control.Applicative import Prelude import Language.Haskell.Ghcid.Types+import Language.Haskell.Ghcid.Escape -- | Parse messages from show modules command. Given the parsed lines -- return a list of (module name, file). parseShowModules :: [String] -> [(String, FilePath)]-parseShowModules xs =+parseShowModules (map unescape -> xs) =+ -- we only return raw values, don't want any escape codes in there [ (takeWhile (not . isSpace) $ trimStart a, takeWhile (/= ',') b) | x <- xs, (a,'(':' ':b) <- [break (== '(') x]] +-- | Parse messages from show paths command. Given the parsed lines+-- return (current working directory, module import search paths)+parseShowPaths :: [String] -> (FilePath, [FilePath])+parseShowPaths (map unescape -> xs)+ | (_:x:_:is) <- xs = (trimStart x, map trimStart is)+ | otherwise = (".",[]) -- | Parse messages given on reload. parseLoad :: [String] -> [Load] -- nub, because cabal repl sometimes does two reloads at the start-parseLoad = nubOrd . f+parseLoad (map Esc -> xs) = nubOrd $ f xs where- f :: [String] -> [Load]- f (('[':xs):rest) =- map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') xs]) ++- f rest+ f :: [Esc] -> [Load]++ -- [1 of 2] Compiling GHCi ( GHCi.hs, interpreted )+ f (xs:rest)+ | Just xs <- stripPrefixE "[" xs+ = map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') $ unescapeE xs]) +++ f rest++ -- GHCi.hs:81:1: Warning: Defined but not used: `foo' f (x:xs)- | not $ " " `isPrefixOf` x+ | not $ " " `isPrefixOfE` x , Just (file,rest) <- breakFileColon x , takeExtension file `elem` [".hs",".lhs",".hs-boot",".lhs-boot"] -- take position, including span if present- , (pos,rest) <- span (\c -> c == ':' || c == '-' || isSpan c || isDigit c) rest- -- separate line and column, ignoring span (we want the start point only)- , [p1,p2] <- map read $ wordsBy (\c -> c == ':' || isSpan c) $ takeWhile (/= '-') pos+ , Just ((pos1, pos2), rest) <- parsePosition rest , (msg,las) <- span isMessageBody xs- , rest <- trimStart $ unwords $ rest : xs- , sev <- if "warning:" `isPrefixOf` lower rest then Warning else Error- = Message sev file (p1,p2) (x:msg) : f las+ , rest <- trimStartE $ unwordsE $ rest : xs+ , sev <- if "warning:" `isPrefixOf` lower (unescapeE rest) then Warning else Error+ = Message sev file pos1 pos2 (map fromEsc $ x:msg) : f las++ -- <no location info>: can't find file: FILENAME f (x:xs)- | Just file <- stripPrefix "<no location info>: can't find file: " x- = Message Error file (0,0) [file ++ ": Can't find file"] : f xs+ | Just file <- stripPrefixE "<no location info>: can't find file: " x+ = Message Error (unescapeE file) (0,0) (0,0) [fromEsc x] : f xs++ -- Module imports form a cycle:+ -- module `Module' (Module.hs) imports itself f (x:xs)- | x == "Module imports form a cycle:"- , (xs,rest) <- span (isPrefixOf " ") xs- , let ms = [takeWhile (/= ')') x | x <- xs, '(':x <- [dropWhile (/= '(') x]]- = Message Error "" (0,0) (x:xs) :- -- need to label the modules in the import cycle so I can find them- [Message Error m (0,0) [] | m <- nubOrd ms] ++ f rest+ | unescapeE x == "Module imports form a cycle:"+ , (xs,rest) <- span (isPrefixOfE " ") xs+ , let ms = [takeWhile (/= ')') x | x <- xs, '(':x <- [dropWhile (/= '(') $ unescapeE x]]+ = [Message Error m (0,0) (0,0) (map fromEsc $ x:xs) | m <- nubOrd ms] ++ f rest++ -- Loaded GHCi configuration from C:\Neil\ghcid\.ghci+ f (x:xs)+ | Just x <- stripPrefixE "Loaded GHCi configuration from " x+ = LoadConfig (unescapeE x) : f xs+ f (_:xs) = f xs f [] = []- isSpan c = c== ',' || c == '(' || c == ')' ++-- 1:2:+-- 1:2-4:+-- (1,2)-(3,4):+parsePosition :: Esc -> Maybe (((Int, Int), (Int, Int)), Esc)+parsePosition x+ | Just (l1, x) <- digit x, Just x <- lit ":" x, Just (c1, x) <- digit x = case () of+ _ | Just x <- lit ":" x -> Just (((l1,c1),(l1,c1)), x)+ | Just x <- lit "-" x, Just (c2,x) <- digit x, Just x <- lit ":" x -> Just (((l1,c1),(l1,c2)), x)+ | otherwise -> Nothing+ | Just (p1, x) <- digits x, Just x <- lit "-" x, Just (p2, x) <- digits x, Just x <- lit ":" x = Just ((p1,p2),x)+ | otherwise = Nothing+ where+ lit = stripPrefixE++ digit x = (,b) <$> readMaybe (unescapeE a)+ where (a,b) = spanE isDigit x++ digits x = do+ x <- lit "(" x+ (l,x) <- digit x+ x <- lit "," x+ (c,x) <- digit x+ x <- lit ")" x+ return ((l,c),x)++ -- After the file location, message bodies are indented (perhaps prefixed by a line number)-isMessageBody :: String -> Bool-isMessageBody xs = isPrefixOf " " xs || case break (=='|') xs of- (prefix, _:_) | all (\x -> isSpace x || isDigit x) prefix -> True+isMessageBody :: Esc -> Bool+isMessageBody xs = isPrefixOfE " " xs || case stripInfixE "|" xs of+ Just (prefix, _) | all (\x -> isSpace x || isDigit x) $ unescapeE prefix -> True _ -> False -- A filename, followed by a colon - be careful to handle Windows drive letters, see #61-breakFileColon :: String -> Maybe (FilePath, String)-breakFileColon (x:':':xs) | isLetter x = first ([x,':']++) <$> stripInfix ":" xs-breakFileColon xs = stripInfix ":" xs+breakFileColon :: Esc -> Maybe (FilePath, Esc)+breakFileColon xs = case stripInfixE ":" xs of+ Nothing -> Nothing+ Just (a,b)+ | [drive] <- unescapeE a, isLetter drive -> first ((++) [drive,':'] . unescapeE) <$> stripInfixE ":" b+ | otherwise -> Just (unescapeE a, b)
src/Language/Haskell/Ghcid/Types.hs view
@@ -4,7 +4,8 @@ module Language.Haskell.Ghcid.Types( GhciError(..), Stream(..),- Load(..), Severity(..), isMessage, isLoading+ Load(..), Severity(..),+ isMessage, isLoading, isLoadConfig ) where import Data.Data@@ -27,24 +28,36 @@ -- | Load messages data Load- = Loading- {loadModule :: String- ,loadFile :: FilePath+ = -- | A module/file was being loaded.+ Loading+ {loadModule :: String -- ^ The module that was being loaded, @Foo.Bar@.+ ,loadFile :: FilePath -- ^ The file that was being loaded, @Foo/Bar.hs@. }- | Message- {loadSeverity :: Severity- ,loadFile :: FilePath- ,loadFilePos :: (Int,Int)- ,loadMessage :: [String]+ | -- | An error/warning was emitted.+ Message+ {loadSeverity :: Severity -- ^ The severity of the message, either 'Warning' or 'Error'.+ ,loadFile :: FilePath -- ^ The file the error relates to, @Foo/Bar.hs@.+ ,loadFilePos :: (Int,Int) -- ^ The position in the file, @(line,col)@, both 1-based. Uses @(0,0)@ for no position information.+ ,loadFilePosEnd :: (Int, Int) -- ^ The end position in the file, @(line,col)@, both 1-based. If not present will be the same as 'loadFilePos'.+ ,loadMessage :: [String] -- ^ The message, split into separate lines, may contain ANSI Escape codes. }+ | -- | A config file was loaded, usually a .ghci file (GHC 8.2 and above only)+ LoadConfig+ {loadFile :: FilePath -- ^ The file that was being loaded, @.ghci@.+ } deriving (Show, Eq, Ord) --- | Is a Load a message with severity?+-- | Is a 'Load' a 'Message'? isMessage :: Load -> Bool isMessage Message{} = True isMessage _ = False --- | Is a Load a module and filename?+-- | Is a 'Load' a 'Loading'? isLoading :: Load -> Bool isLoading Loading{} = True isLoading _ = False++-- | Is a 'Load' a 'LoadConfig'?+isLoadConfig :: Load -> Bool+isLoadConfig LoadConfig{} = True+isLoadConfig _ = False
src/Language/Haskell/Ghcid/Util.hs view
@@ -1,9 +1,11 @@ -- | Utility functions module Language.Haskell.Ghcid.Util(+ ghciFlagsRequired, ghciFlagsRequiredVersioned,+ ghciFlagsUseful, ghciFlagsUsefulVersioned, dropPrefixRepeatedly,- chunksOfWord,- outWith, outStrLn,+ outStr, outStrLn,+ ignored, allGoodMessage, getModTime, getModTimeResolution, getShortTime ) where@@ -14,9 +16,9 @@ import System.IO.Extra import System.FilePath import System.Info.Extra+import System.Console.ANSI import Data.Version.Extra import Data.List.Extra-import Data.Char import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime@@ -28,6 +30,33 @@ import Prelude +-- | Flags that are required for ghcid to function and are supported on all GHC versions+ghciFlagsRequired :: [String]+ghciFlagsRequired =+ ["-fno-break-on-exception","-fno-break-on-error" -- see #43+ ,"-v1" -- see #110+ ]++-- | Flags that are required for ghcid to function, but are only supported on some GHC versions+ghciFlagsRequiredVersioned :: [String]+ghciFlagsRequiredVersioned =+ ["-fno-hide-source-paths" -- see #132, GHC 8.2 and above+ ]++-- | Flags that make ghcid work better and are supported on all GHC versions+ghciFlagsUseful :: [String]+ghciFlagsUseful =+ ["-ferror-spans" -- see #148+ ,"-j" -- see #153, GHC 7.8 and above, but that's all I support anyway+ ]++-- | Flags that make ghcid work better, but are only supported on some GHC versions+ghciFlagsUsefulVersioned :: [String]+ghciFlagsUsefulVersioned =+ ["-fdiagnostics-color=always" -- see #144, GHC 8.2 and above+ ]++ -- | Drop a prefix from a list, no matter how many times that prefix is present dropPrefixRepeatedly :: Eq a => [a] -> [a] -> [a] dropPrefixRepeatedly [] s = s@@ -38,25 +67,25 @@ lock :: Lock lock = unsafePerformIO newLock -outWith :: IO a -> IO a-outWith = withLock lock+-- | Output a string with some level of locking+outStr :: String -> IO ()+outStr msg = do+ evaluate $ length $ show msg+ withLock lock $ putStr msg outStrLn :: String -> IO ()-outStrLn = outWith . putStrLn+outStrLn xs = outStr $ xs ++ "\n" +-- | Ignore all exceptions coming from an action+ignored :: IO () -> IO ()+ignored act = do+ bar <- newBarrier+ forkFinally act $ const $ signalBarrier bar ()+ waitBarrier bar -- | The message to show when no errors have been reported allGoodMessage :: String-allGoodMessage = "All good"---- | Like chunksOf, but deal with words up to some gap.--- Flows onto a subsequent line if less than N characters end up being empty.-chunksOfWord :: Int -> Int -> String -> [String]-chunksOfWord mx gap = repeatedly $ \x ->- let (a,b) = splitAt mx x in- if null b then (a, []) else- let (a1,a2) = breakEnd isSpace a in- if length a2 <= gap then (a1, a2 ++ b) else (a, dropWhile isSpace b)+allGoodMessage = setSGRCode [SetColor Foreground Dull Green] ++ "All good" ++ setSGRCode [] -- | Given a 'FilePath' return either 'Nothing' (file does not exist) or 'Just' (the modification time) getModTime :: FilePath -> IO (Maybe UTCTime)
src/Session.hs view
@@ -9,10 +9,13 @@ ) where import Language.Haskell.Ghcid+import Language.Haskell.Ghcid.Escape import Language.Haskell.Ghcid.Util+import Language.Haskell.Ghcid.Types import Data.IORef import System.Time.Extra import System.Process+import System.FilePath import Control.Exception.Extra import Control.Concurrent.Extra import Control.Monad.Extra@@ -24,8 +27,9 @@ data Session = Session {ghci :: IORef (Maybe Ghci) -- ^ The Ghci session, or Nothing if there is none- ,command :: IORef (Maybe String) -- ^ The last command passed to sessionStart+ ,command :: IORef (Maybe (String, [String])) -- ^ The last command passed to sessionStart, setup operations ,warnings :: IORef [Load] -- ^ The warnings from the last load+ ,curdir :: IORef FilePath -- ^ The current working directory ,running :: Var Bool -- ^ Am I actively running an async command ,withThread :: ThreadId -- ^ Thread that called withSession }@@ -41,6 +45,7 @@ ghci <- newIORef Nothing command <- newIORef Nothing warnings <- newIORef []+ curdir <- newIORef "." running <- newVar False debugShutdown "Starting session" withThread <- myThreadId@@ -56,22 +61,28 @@ -- | Kill. Wait just long enough to ensure you've done the job, but not to see the results. kill :: Ghci -> IO ()-kill ghci = ignore $ do+kill ghci = ignored $ do timeout 5 $ do debugShutdown "Before quit"- ignore $ quit ghci+ ignored $ quit ghci debugShutdown "After quit" debugShutdown "Before terminateProcess"- terminateProcess $ process ghci+ ignored $ terminateProcess $ process ghci debugShutdown "After terminateProcess" +loadedModules :: [Load] -> [FilePath]+loadedModules = nubOrd . map loadFile . filter (not . isLoadConfig)++qualify :: FilePath -> [Load] -> [Load]+qualify dir xs = [x{loadFile = dir </> loadFile x} | x <- xs]+ -- | Spawn a new Ghci process at a given command line. Returns the load messages, plus -- the list of files that were observed (both those loaded and those that failed to load).-sessionStart :: Session -> String -> IO ([Load], [FilePath])-sessionStart Session{..} cmd = do+sessionStart :: Session -> String -> [String] -> IO ([Load], [FilePath])+sessionStart Session{..} cmd setup = do modifyVar_ running $ const $ return False- writeIORef command $ Just cmd+ writeIORef command $ Just (cmd, setup) -- cleanup any old instances whenJustM (readIORef ghci) $ \v -> do@@ -80,9 +91,19 @@ -- start the new outStrLn $ "Loading " ++ cmd ++ " ..."- (v, messages) <- startGhci cmd Nothing $ const outStrLn- writeIORef ghci $ Just v+ (v, messages) <- mask $ \unmask -> do+ (v, messages) <- unmask $ startGhci cmd Nothing $ const outStrLn+ writeIORef ghci $ Just v+ return (v, messages) + -- do whatever preparation was requested+ exec v $ unlines setup++ -- capture stdout+ (dir, _) <- showPaths v+ writeIORef curdir dir+ messages <- return $ qualify dir messages+ -- install a handler forkIO $ do waitForProcess $ process v@@ -94,14 +115,14 @@ -- handle what the process returned messages <- return $ mapMaybe tidyMessage messages writeIORef warnings [m | m@Message{..} <- messages, loadSeverity == Warning]- return (messages, nubOrd $ map loadFile messages)+ return (messages, loadedModules messages) -- | Call 'sessionStart' at the previous command. sessionRestart :: Session -> IO ([Load], [FilePath]) sessionRestart session@Session{..} = do- Just cmd <- readIORef command- sessionStart session cmd+ Just (cmd, setup) <- readIORef command+ sessionStart session cmd setup -- | Reload, returning the same information as 'sessionStart'. In particular, any@@ -118,9 +139,10 @@ if stuck then sessionRestart session else do -- actually reload Just ghci <- readIORef ghci- messages <- mapMaybe tidyMessage <$> reload ghci- loaded <- map snd <$> showModules ghci- let reloaded = nubOrd $ filter (/= "") $ map loadFile messages+ dir <- readIORef curdir+ messages <- mapMaybe tidyMessage . qualify dir <$> reload ghci+ loaded <- map ((dir </>) . snd) <$> showModules ghci+ let reloaded = loadedModules messages warn <- readIORef warnings -- only keep old warnings from files that are still loaded, but did not reload@@ -155,9 +177,9 @@ -- | Ignore entirely pointless messages and remove unnecessary lines. tidyMessage :: Load -> Maybe Load tidyMessage Message{loadSeverity=Warning, loadMessage=[_,x]}- | x == " -O conflicts with --interactive; -O ignored." = Nothing+ | unescape x == " -O conflicts with --interactive; -O ignored." = Nothing tidyMessage m@Message{..}- = Just m{loadMessage = filter (\x -> not $ any (`isPrefixOf` x) bad) loadMessage}+ = Just m{loadMessage = filter (\x -> not $ any (`isPrefixOf` unescape x) bad) loadMessage} where bad = [" except perhaps to import instances from" ," To import instances alone, use: import "] tidyMessage x = Just x
src/Test/Ghcid.hs view
@@ -20,6 +20,7 @@ import Test.Tasty.HUnit import Ghcid+import Language.Haskell.Ghcid.Escape import Language.Haskell.Ghcid.Util import Data.Functor import Prelude@@ -28,6 +29,7 @@ ghcidTest :: TestTree ghcidTest = testGroup "Ghcid test" [basicTest+ ,cdTest ,dotGhciTest ,cabalTest ,stackTest@@ -67,7 +69,10 @@ Just got -> assertApproxInfix want got sleep =<< getModTimeResolution - let output = writeChan chan . filter (/= "") . map snd+ let output msg = do+ let msg2 = filter (/= "") msg+ putStr $ unlines $ map ("%PRINT: "++) msg2+ writeChan chan msg2 done <- newBarrier res <- bracket (flip forkFinally (const $ signalBarrier done ()) $@@ -83,7 +88,7 @@ assertApproxInfix :: [String] -> [String] -> IO () assertApproxInfix want got = do -- Spacing and quotes tend to be different on different GHCi versions- let simple = lower . filter (\x -> isLetter x || isDigit x || x == ':')+ let simple = lower . filter (\x -> isLetter x || isDigit x || x == ':') . unescape got2 = simple $ unwords got all (`isInfixOf` got2) (map simple want) @? "Expected " ++ show want ++ ", got " ++ show got@@ -92,6 +97,7 @@ write :: FilePath -> String -> IO () write file x = do print ("writeFile",file,x)+ createDirectoryIfMissing True $ takeDirectory file writeFile file x append :: FilePath -> String -> IO ()@@ -150,13 +156,29 @@ -- note that due to GHC bug #9648 and #11596 this doesn't work with newer GHC -- see https://ghc.haskell.org/trac/ghc/ticket/11596 rename "Util.hs" "Util2.hs"- require ["Main.hs:1:8:","Could not find module `Util'"]+ require ["Main.hs:1:8","Could not find module `Util'"] rename "Util2.hs" "Util.hs" require [allGoodMessage] -- after this point GHC bugs mean nothing really works too much +cdTest :: TestTree+cdTest = testCase "Cd basic" $ freshDir $ do+ write "foo/Main.hs" "main = print 1"+ write "foo/Util.hs" "import Bob"+ write "foo/.ghci" ":load Main"+ ignore $ void $ system "chmod go-w foo foo/.ghci"+ ghcVer <- readVersion <$> systemOutput_ "ghc --numeric-version"+ -- GHC 8.0 and lower don't emit the LoadConfig messages+ withGhcid ("-ccd foo && ghci" : ["--restart=foo/.ghci" | ghcVer < makeVersion [8,2]]) $ \require -> do+ require [allGoodMessage]+ write "foo/Main.hs" "x"+ require ["Main.hs:1:1"," Parse error:"]+ write "foo/.ghci" ":load Util"+ require ["Util.hs:1:","`Bob'"]++ dotGhciTest :: TestTree dotGhciTest = testCase "Ghcid .ghci" $ copyDir "test/foo" $ do write "test.txt" ""@@ -194,11 +216,14 @@ stackTest :: TestTree stackTest = testCase "Ghcid Stack" $ copyDir "test/bar" $ whenExecutable "stack" $ do- system_ "stack init"+ system_ "stack init --resolver=nightly" -- must match what the CI does, or it takes too long createDirectoryIfMissing True ".stack-work" withGhcid [] $ \require -> do- require [allGoodMessage]+ require [allGoodMessage ++ " (4 modules, at "]+ -- the .ghci file we watch was created _after_ we started loading stack+ -- so ghcid is correct to immediately reload, in case it changed+ require [allGoodMessage ++ " (4 modules, at "] append "src/Literate.lhs" "> x" require ["src/Literate.lhs:5:3","Parse error:"] {-
src/Test/Parser.hs view
@@ -11,9 +11,14 @@ parserTests :: TestTree parserTests = testGroup "Parser tests" [testParseShowModules+ ,testParseShowPaths ,testParseLoad ,testParseLoadGhc82 ,testParseLoadSpans+ ,testParseLoadCycles+ ,testParseLoadCyclesSelf+ ,testParseLoadEscapeCodes+ ,testMissingFile ] testParseShowModules :: TestTree@@ -25,6 +30,16 @@ ,("AI.Neural.WiscDigit","src/AI/Neural/WiscDigit.hs") ] +testParseShowPaths :: TestTree+testParseShowPaths = testCase "Show Paths" $ parseShowPaths+ ["current working directory:"+ ," C:\\Neil\\ghcid"+ ,"module import search paths:"+ ," ."+ ," src"+ ] @?=+ ("C:\\Neil\\ghcid",[".","src"])+ testParseLoad :: TestTree testParseLoad = testCase "Load Parsing" $ parseLoad ["[1 of 2] Compiling GHCi ( GHCi.hs, interpreted )"@@ -46,12 +61,27 @@ ," Expected: `Boot'" ] @?= [Loading "GHCi" "GHCi.hs"- ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (70,1), loadMessage = ["GHCi.hs:70:1: Parse error: naked expression at top level"]}- ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (72,13), loadMessage = ["GHCi.hs:72:13:"," No instance for (Num ([String] -> [String]))"," arising from the literal `1'"," Possible fix:"," add an instance declaration for (Num ([String] -> [String]))"," In the expression: 1"," In an equation for `parseLoad': parseLoad = 1"]}- ,Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (81,1), loadMessage = ["GHCi.hs:81:1: Warning: Defined but not used: `foo'"]}- ,Message {loadSeverity = Warning, loadFile = "C:\\GHCi.hs", loadFilePos = (82,1), loadMessage = ["C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]}- ,Message {loadSeverity = Warning, loadFile = "src\\Haskell.hs", loadFilePos = (4,23), loadMessage = ["src\\Haskell.hs:4:23:"," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"]}- ,Message {loadSeverity = Error, loadFile = "src\\Boot.hs-boot", loadFilePos = (2,8), loadMessage = ["src\\Boot.hs-boot:2:8:"," File name does not match module name:"," Saw: `BootX'"," Expected: `Boot'"]}+ ,Message Error "GHCi.hs" (70,1) (70,1)+ ["GHCi.hs:70:1: Parse error: naked expression at top level"]+ ,Message Error "GHCi.hs" (72,13) (72,13)+ ["GHCi.hs:72:13:"+ ," No instance for (Num ([String] -> [String]))"+ ," arising from the literal `1'"," Possible fix:"+ ," add an instance declaration for (Num ([String] -> [String]))"+ ," In the expression: 1"+ ," In an equation for `parseLoad': parseLoad = 1"]+ ,Message Warning "GHCi.hs" (81,1) (81,1)+ ["GHCi.hs:81:1: Warning: Defined but not used: `foo'"]+ ,Message Warning "C:\\GHCi.hs" (82,1) (82,1)+ ["C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]+ ,Message Warning "src\\Haskell.hs" (4,23) (4,23)+ ["src\\Haskell.hs:4:23:"+ ," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"]+ ,Message Error "src\\Boot.hs-boot" (2,8) (2,8)+ ["src\\Boot.hs-boot:2:8:"+ ," File name does not match module name:"+ ," Saw: `BootX'"+ ," Expected: `Boot'"] ] testParseLoadGhc82 :: TestTree@@ -61,12 +91,77 @@ ," |" ,"30 | dx = ' ^* delta" ," | ^^"+ ,"Loaded GHCi configuration from C:\\Neil\\ghcid\\.ghci" ] @?= [Loading "Physics" "Physics.hs"- ,Message {loadSeverity = Error, loadFile = "Physics.hs", loadFilePos = (30,18), loadMessage = ["Physics.hs:30:18: error: parse error on input ‘^*’" ," |" ,"30 | dx = ' ^* delta" ," | ^^"]}+ ,Message Error "Physics.hs" (30,18) (30,18)+ ["Physics.hs:30:18: error: parse error on input ‘^*’"+ ," |"+ ,"30 | dx = ' ^* delta"+ ," | ^^"]+ ,LoadConfig "C:\\Neil\\ghcid\\.ghci" ] --- | Test when error messages include spans (-ferror-spans)+testMissingFile = testCase "Starting ghci with a non-existent filename" $ parseLoad+ ["<no location info>: error: can't find file: bob.hs"+ ] @?=+ []++testParseLoadCyclesSelf = testCase "Module cycle with itself" $ parseLoad+ ["Module imports form a cycle:"+ ," module `Language.Haskell.Ghcid.Parser' (src\\Language\\Haskell\\Ghcid\\Parser.hs) imports itself"+ ] @?=+ [Message Error "src\\Language\\Haskell\\Ghcid\\Parser.hs" (0,0) (0,0)+ ["Module imports form a cycle:"+ ," module `Language.Haskell.Ghcid.Parser' (src\\Language\\Haskell\\Ghcid\\Parser.hs) imports itself"]+ ]++testParseLoadCycles = testCase "Module cycle" $ parseLoad+ ["[ 4 of 13] Compiling Language.Haskell.Ghcid.Parser ( src\\Language\\Haskell\\Ghcid\\Parser.hs, interpreted )"+ ,"Module imports form a cycle:"+ ," module `Language.Haskell.Ghcid.Util' (src\\Language\\Haskell\\Ghcid\\Util.hs)"+ ," imports `Language.Haskell.Ghcid' (src\\Language\\Haskell\\Ghcid.hs)"+ ," which imports `Language.Haskell.Ghcid.Util' (src\\Language\\Haskell\\Ghcid\\Util.hs)"+ ] @?=+ let msg = ["Module imports form a cycle:"+ ," module `Language.Haskell.Ghcid.Util' (src\\Language\\Haskell\\Ghcid\\Util.hs)"+ ," imports `Language.Haskell.Ghcid' (src\\Language\\Haskell\\Ghcid.hs)"+ ," which imports `Language.Haskell.Ghcid.Util' (src\\Language\\Haskell\\Ghcid\\Util.hs)"] in+ [Loading "Language.Haskell.Ghcid.Parser" "src\\Language\\Haskell\\Ghcid\\Parser.hs"+ ,Message Error "src\\Language\\Haskell\\Ghcid\\Util.hs" (0,0) (0,0) msg+ ,Message Error "src\\Language\\Haskell\\Ghcid.hs" (0,0) (0,0) msg+ ]++testParseLoadEscapeCodes = testCase "Escape codes as enabled by -fdiagnostics-color=always" $ parseLoad+ ["\ESC[;1msrc\\Language\\Haskell\\Ghcid\\Types.hs:11:1: \ESC[;1m\ESC[35mwarning:\ESC[0m\ESC[0m\ESC[;1m [\ESC[;1m\ESC[35m-Wunused-imports\ESC[0m\ESC[0m\ESC[;1m]\ESC[0m\ESC[0m\ESC[;1m"+ ," The import of `Data.Data' is redundant"+ ," except perhaps to import instances from `Data.Data'"+ ," To import instances alone, use: import Data.Data()\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m11 |\ESC[0m\ESC[0m \ESC[;1m\ESC[35mimport Data.Data\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m\ESC[;1m\ESC[35m ^^^^^^^^^^^^^^^^\ESC[0m\ESC[0m"+ ,"\ESC[0m\ESC[0m\ESC[0m"+ ,"\ESC[;1msrc\\Language\\Haskell\\Ghcid\\Util.hs:11:1: \ESC[;1m\ESC[31merror:\ESC[0m\ESC[0m\ESC[;1m\ESC[0m\ESC[0m\ESC[;1m"+ ," Could not find module `Language.Haskell.Ghcid.None'\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m11 |\ESC[0m\ESC[0m \ESC[;1m\ESC[31mimport Language.Haskell.Ghcid.None\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m\ESC[;1m\ESC[31m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\ESC[0m\ESC[0m"+ ,"\ESC[0m\ESC[0m\ESC[0m"+ ] @?=+ [Message Warning "src\\Language\\Haskell\\Ghcid\\Types.hs" (11,1) (11,1)+ ["\ESC[;1msrc\\Language\\Haskell\\Ghcid\\Types.hs:11:1: \ESC[;1m\ESC[35mwarning:\ESC[0m\ESC[0m\ESC[;1m [\ESC[;1m\ESC[35m-Wunused-imports\ESC[0m\ESC[0m\ESC[;1m]\ESC[0m\ESC[0m\ESC[;1m"+ ," The import of `Data.Data' is redundant"+ ," except perhaps to import instances from `Data.Data'"+ ," To import instances alone, use: import Data.Data()\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m","\ESC[;1m\ESC[34m11 |\ESC[0m\ESC[0m \ESC[;1m\ESC[35mimport Data.Data\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m\ESC[;1m\ESC[35m ^^^^^^^^^^^^^^^^\ESC[0m\ESC[0m"]+ ,Message Error "src\\Language\\Haskell\\Ghcid\\Util.hs" (11,1) (11,1)+ ["\ESC[;1msrc\\Language\\Haskell\\Ghcid\\Util.hs:11:1: \ESC[;1m\ESC[31merror:\ESC[0m\ESC[0m\ESC[;1m\ESC[0m\ESC[0m\ESC[;1m"+ ," Could not find module `Language.Haskell.Ghcid.None'\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m","\ESC[;1m\ESC[34m11 |\ESC[0m\ESC[0m \ESC[;1m\ESC[31mimport Language.Haskell.Ghcid.None\ESC[0m\ESC[0m"+ ,"\ESC[;1m\ESC[34m |\ESC[0m\ESC[0m\ESC[;1m\ESC[31m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\ESC[0m\ESC[0m"]+ ]+ testParseLoadSpans :: TestTree testParseLoadSpans = testCase "Load Parsing when -ferror-spans is enabled" $ parseLoad ["[1 of 2] Compiling GHCi ( GHCi.hs, interpreted )"@@ -90,11 +185,29 @@ ," A do-notation statement discarded a result of type ‘[()]’" ] @?= [Loading "GHCi" "GHCi.hs"- ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (70,1), loadMessage = ["GHCi.hs:70:1-2: Parse error: naked expression at top level"]}- ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (72,13), loadMessage = ["GHCi.hs:72:13-14:"," No instance for (Num ([String] -> [String]))"," arising from the literal `1'"," Possible fix:"," add an instance declaration for (Num ([String] -> [String]))"," In the expression: 1"," In an equation for `parseLoad': parseLoad = 1"]}- ,Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (81,1), loadMessage = ["GHCi.hs:81:1-15: Warning: Defined but not used: `foo'"]}- ,Message {loadSeverity = Warning, loadFile = "C:\\GHCi.hs", loadFilePos = (82,1), loadMessage = ["C:\\GHCi.hs:82:1-17: warning: Defined but not used: \8216foo\8217"]}- ,Message {loadSeverity = Warning, loadFile = "src\\Haskell.hs", loadFilePos = (4,23), loadMessage = ["src\\Haskell.hs:4:23-24:"," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"]}- ,Message {loadSeverity = Error, loadFile = "src\\Boot.hs-boot", loadFilePos = (2,8), loadMessage = ["src\\Boot.hs-boot:2:8-5:"," File name does not match module name:"," Saw: `BootX'"," Expected: `Boot'"]}- ,Message {loadSeverity = Warning, loadFile = "/src/TrieSpec.hs", loadFilePos = (192,7), loadMessage = ["/src/TrieSpec.hs:(192,7)-(193,76): Warning:"," A do-notation statement discarded a result of type ‘[()]’"]}+ ,Message Error "GHCi.hs" (70,1) (70,2)+ ["GHCi.hs:70:1-2: Parse error: naked expression at top level"]+ ,Message Error "GHCi.hs" (72,13) (72,14)+ ["GHCi.hs:72:13-14:"+ ," No instance for (Num ([String] -> [String]))"+ ," arising from the literal `1'"+ ," Possible fix:"+ ," add an instance declaration for (Num ([String] -> [String]))"+ ," In the expression: 1"+ ," In an equation for `parseLoad': parseLoad = 1"]+ ,Message Warning "GHCi.hs" (81,1) (81,15)+ ["GHCi.hs:81:1-15: Warning: Defined but not used: `foo'"]+ ,Message Warning "C:\\GHCi.hs" (82,1) (82,17)+ ["C:\\GHCi.hs:82:1-17: warning: Defined but not used: \8216foo\8217"]+ ,Message Warning "src\\Haskell.hs" (4,23) (4,24)+ ["src\\Haskell.hs:4:23-24:"+ ," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"]+ ,Message Error "src\\Boot.hs-boot" (2,8) (2,5)+ ["src\\Boot.hs-boot:2:8-5:"+ ," File name does not match module name:"+ ," Saw: `BootX'"+ ," Expected: `Boot'"]+ ,Message Warning "/src/TrieSpec.hs" (192,7) (193,76)+ ["/src/TrieSpec.hs:(192,7)-(193,76): Warning:"+ ," A do-notation statement discarded a result of type ‘[()]’"] ]
src/Test/Util.hs view
@@ -5,6 +5,7 @@ import Test.Tasty.HUnit import Language.Haskell.Ghcid.Util+import Language.Haskell.Ghcid.Escape utilsTests :: TestTree utilsTests = testGroup "Utility tests"@@ -22,6 +23,6 @@ chunksOfWordTests :: TestTree chunksOfWordTests = testGroup "chunksOfWord"- [testCase "Max 0" $ chunksOfWord 4 0 "ab cd efgh" @?= ["ab c","d ef","gh"]- ,testCase "Max 2" $ chunksOfWord 4 2 "ab cd efgh" @?= ["ab ","cd ","efgh"]+ [testCase "Max 0" $ chunksOfWordE 4 0 (Esc "ab cd efgh") @?= map Esc ["ab c","d ef","gh"]+ ,testCase "Max 2" $ chunksOfWordE 4 2 (Esc "ab cd efgh") @?= map Esc ["ab ","cd ","efgh"] ]