ghcid 0.8.9 → 1.0.0
raw patch · 28 files changed
+2037/−1536 lines, 28 filesdep +asyncdep +base64-bytestringdep +bytestringnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: async, base64-bytestring, bytestring, cryptohash-sha256, microaeson, network, temporary, text
API changes (from Hackage documentation)
Files
- CHANGES.txt +8/−0
- LICENSE +1/−1
- README.md +12/−3
- app/Ghcid.hs +512/−0
- app/Language/Haskell/Ghcid/Terminal.hs +83/−0
- app/Server.hs +312/−0
- app/Session.hs +282/−0
- app/Wait.hs +120/−0
- ghcid.cabal +27/−6
- src/Ghcid.hs +0/−477
- src/Language/Haskell/Ghcid.hs +8/−18
- src/Language/Haskell/Ghcid/Parser.hs +11/−1
- src/Language/Haskell/Ghcid/Terminal.hs +0/−83
- src/Language/Haskell/Ghcid/Util.hs +67/−8
- src/Session.hs +0/−258
- src/Test.hs +0/−25
- src/Test/API.hs +0/−37
- src/Test/Common.hs +0/−13
- src/Test/Ghcid.hs +0/−241
- src/Test/Parser.hs +0/−213
- src/Test/Util.hs +0/−31
- src/Wait.hs +0/−121
- test/Test.hs +26/−0
- test/Test/API.hs +61/−0
- test/Test/Common.hs +13/−0
- test/Test/Ghcid.hs +222/−0
- test/Test/Parser.hs +230/−0
- test/Test/Util.hs +42/−0
CHANGES.txt view
@@ -1,5 +1,13 @@ Changelog for ghcid (* = breaking change) +1.0.0, released 2026-08-18+ #397, #399, #400, promptly clean up entire process groups and force+ termination when GHCi is unresponsive+ #402, add a socket server for VS Code navigation and diagnostics+ #406, fix module-cycle crashes and Windows hangs+ Support GHC 9.8, 9.10, 9.12 and 9.15+ Fix Cabal script mode, --server, diagnostics, and module-cycle handling+ 0.8.9, released 2023-07-02 #375, fix crash when modules are renamed or deleted in GHC 9.6 #378, write output of the linter into output files
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2014-2023.+Copyright Neil Mitchell 2014-2026. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,4 +1,4 @@-# ghcid [](https://hackage.haskell.org/package/ghcid) [](https://www.stackage.org/package/ghcid) [](https://github.com/ndmitchell/ghcid/actions)+# ghcid [](https://hackage.haskell.org/package/ghcid) [](https://www.stackage.org/package/ghcid) [](https://github.com/ndmitchell/ghcid/actions) Either "GHCi as a daemon" or "GHC + a bit of an IDE". To a first approximation, it opens `ghci` and runs `:reload` whenever your source code changes, formatting the output to fit a fixed height console. Unlike other Haskell development tools, `ghcid` is intended to be _incredibly simple_. In particular, it doesn't integrate with any editors, doesn't provide access to the `ghci` it starts, doesn't depend on GHC the library and doesn't start web servers. @@ -6,7 +6,7 @@ ### Using it -Run `stack install ghcid` or `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`.+Run `stack install ghcid`, `brew install ghcid` or `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): @@ -92,7 +92,7 @@ Ghcid automatically appends `-fno-code` to the command line, which makes the reload cycle about twice as fast. Unfortunately GHC 8.0 and 8.2 suffer from [bug 10600](https://ghc.haskell.org/trac/ghc/ticket/10600) which means `-fno-code` also disables pattern matching warnings. On these versions, either accept no pattern match warnings or use `-c` to specify a command line to start `ghci` that doesn't include `-fno-code`. From GHC 8.4 this problem no longer exists. #### 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.+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 suppress 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 colors 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"`.@@ -114,3 +114,12 @@ #### Why do I get "addWatch: resource exhausted (No space left on device)" or "openFile: resource exhausted (Too many open files)" on my Mac? The Mac has a fairly low limit on the number of file handles available. You can increase it with: `sudo sysctl -w fs.inotify.max_user_watches=262144; sudo sysctl -p`++### Windows dev on GCP++If you want a disposable native Windows machine for debugging Windows-specific behavior, there is a helper script in the repository for creating or reusing a GCP VM and connecting to it over SSH:++```+cp .env.example .env+dotenv run -- python3 ssh-windows-gcp.py+```
+ app/Ghcid.hs view
@@ -0,0 +1,512 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, TupleSections, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-cse #-}++-- | The application entry point+module Ghcid(main, mainWithTerminal, TermSize(..), WordWrap(..), shouldWatchLoadConfig) where++import Control.Exception+import System.IO.Error+import Control.Applicative+import Control.Monad.Extra+import Data.List.Extra+import Data.Maybe+import Data.Ord+import Data.Tuple.Extra+import Data.Version+import Session+import Server+import qualified System.Console.Terminal.Size as Term+import System.Console.CmdArgs+import System.Console.CmdArgs.Explicit+import System.Console.ANSI+import System.Environment+import System.Directory.Extra+import System.Time.Extra+import System.Exit+import System.FilePath+import System.Process+import System.Info+import System.IO.Extra+import System.IO.Temp++import Paths_ghcid+import Language.Haskell.Ghcid.Escape+import Language.Haskell.Ghcid.Terminal+import Language.Haskell.Ghcid.Util+import Language.Haskell.Ghcid.Types+import Wait++import Prelude+++-- | Command line options+data Options = Options+ {command :: String+ ,arguments :: [String]+ ,test :: [String]+ ,test_message :: String+ ,run :: [String]+ ,warnings :: Bool+ ,lint :: Maybe String+ ,no_status :: Bool+ ,clear :: Bool+ ,reverse_errors :: Bool+ ,no_height_limit :: Bool+ ,height :: Maybe Int+ ,width :: Maybe Int+ ,topmost :: Bool+ ,no_title :: Bool+ ,project :: String+ ,reload :: [FilePath]+ ,restart :: [FilePath]+ ,directory :: FilePath+ ,outputfile :: [FilePath]+ ,ignoreLoaded :: Bool+ ,poll :: Maybe Seconds+ ,max_messages :: Maybe Int+ ,color :: ColorMode+ ,setup :: [String]+ ,no_cabal_repl_rtsopts :: Bool+ ,allow_eval :: Bool+ ,server :: Bool+ ,target :: [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 = "" &= 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"+ ,test_message = "Running test..." &= typ "MESSAGE" &= help "Message to show before running the test (defaults to \"Running test...\")"+ ,run = [] &= name "r" &= typ "EXPR" &= opt "main" &= help "Command to run after successful loading (like --test but defaults to main)"+ ,warnings = False &= name "W" &= help "Allow tests to run even with warnings"+ ,lint = Nothing &= typ "COMMAND" &= name "lint" &= opt "hlint" &= help "Linter to run if there are no errors. Defaults to hlint."+ ,no_status = False &= name "S" &= help "Suppress status messages"+ ,clear = False &= name "clear" &= help "Clear screen when reloading"+ ,reverse_errors = False &= help "Reverse output order (works best with --no-height-limit)"+ ,no_height_limit = False &= name "no-height-limit" &= help "Disable height limit"+ ,height = Nothing &= help "Number of lines to use (defaults to console height)"+ ,width = Nothing &= name "w" &= help "Number of columns to use (defaults to console width)"+ ,topmost = False &= name "t" &= help "Set window topmost (Windows only)"+ ,no_title = False &= help "Don't update the shell title/icon"+ ,project = "" &= typ "NAME" &= help "Name of the project, defaults to current directory"+ ,restart = [] &= typ "PATH" &= help "Restart the command when the given file or directory contents change (defaults to .ghci and any .cabal file, unless when using stack or a custom command)"+ ,reload = [] &= typ "PATH" &= help "Reload when the given file or directory contents change (defaults to none)"+ ,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."+ ,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>"+ ,no_cabal_repl_rtsopts = False &= explicit &= name "no-cabal-repl-rtsopts" &= help "Disable default +RTS -N -RTS when using the auto-selected cabal repl command"+ ,allow_eval = False &= name "allow-eval" &= help "Execute REPL commands in comments"+ ,server = False &= explicit &= name "server" &= help "Enable the local ghcid socket server"+ ,target = [] &= typ "TARGET" &= help "Target Component to build (e.g. lib:foo for Cabal, foo:lib for Stack)"+ } &= verbosity &=+ program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version)+++{-+What happens on various command lines:++Hlint with no .ghci file:+- cabal repl - prompt with Language.Haskell.HLint loaded+- cabal exec ghci Sample.hs - prompt with Sample.hs loaded+- ghci - prompt with nothing loaded+- ghci Sample.hs - prompt with Sample.hs loaded+- stack ghci - prompt with all libraries and Main loaded++Hlint with a .ghci file:+- cabal repl - loads everything twice, prompt with Language.Haskell.HLint loaded+- cabal exec ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded+- ghci - prompt with everything+- ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded+- stack ghci - loads everything first, then prompt with libraries and Main loaded++Warnings:+- cabal repl won't pull in any C files (e.g. hoogle)+- cabal exec ghci won't work with modules that import an autogen Paths module++As a result, we prefer to give users full control with a .ghci file, if available+-}+autoOptions :: Options -> String -> IO Options+autoOptions o@Options{..} ghciScript+ | command /= "" = pure $ f [command] []+ | otherwise = do+ curdir <- getCurrentDirectory+ files <- getDirectoryContents "."++ -- use unsafePerformIO to get nicer pattern matching for logic (read-only operations)+ let findStack dir = flip catchIOError (const $ pure Nothing) $ do+ let yaml = dir </> "stack.yaml"+ b <- doesFileExist yaml &&^ doesDirectoryExist (dir </> ".stack-work")+ pure $ if b then Just yaml else Nothing+ stackFile <- firstJustM findStack [".",".."] -- stack file might be parent, see #62++ let cabal = map (curdir </>) $ filter ((==) ".cabal" . takeExtension) files+ let isLib = isPrefixOf "lib:" -- `lib:foo` is the Cabal format+ let noCode = [ "-fno-code"+ | null test+ && null run+ && not allow_eval+ && (isJust stackFile || all isLib target) ]+ let opts = noCode ++ ghciFlagsRequired ++ ghciFlagsUseful ++ ["-ghci-script=" ++ ghciScript]+ pure $ case () of+ _ | Just stack <- stackFile ->+ let flags = if null arguments then+ "stack ghci" : target ++ "--test --bench" :+ ["--no-load" | ".ghci" `elem` files] +++ map ("--ghci-options=" ++) opts+ else+ "stack exec --test --bench -- ghci" : opts+ in f flags $ stack:cabal+ | cabal /= [] ->+ let rtsopts = ["\"+RTS -N -RTS\"" | not no_cabal_repl_rtsopts]+ useCabal = ["cabal","repl"] ++ target ++ map ("--repl-options=" ++) (rtsopts ++ opts)+ useGhci = "cabal exec -- ghci":opts+ in f (if null arguments then useCabal else useGhci) cabal+ | ".ghci" `elem` files -> f ("ghci":opts) [curdir </> ".ghci"]+ | otherwise -> f ("ghci":opts) []+ where+ f c r = o{command = unwords $ c ++ map escape arguments, arguments = [], restart = restart ++ r, run = [], test = run ++ test}++-- | Simple escaping for command line arguments. Wraps a string in double quotes if it contains a space.+escape x | ' ' `elem` x = "\"" ++ x ++ "\""+ | otherwise = x++shouldWatchLoadConfig :: FilePath -> Bool+shouldWatchLoadConfig file =+ not $ takeFileName file == "setcwd.ghci" && hasScriptBuildsParent (splitDirectories file)+ where+ hasScriptBuildsParent (_:cabal:scriptBuilds:_)+ | cabal == ".cabal" && scriptBuilds == "script-builds" = True+ hasScriptBuildsParent (_:xs) = hasScriptBuildsParent xs+ hasScriptBuildsParent [] = False++-- | Use arguments from .ghcid if present+withGhcidArgs :: IO a -> IO a+withGhcidArgs act = do+ b <- doesFileExist ".ghcid"+ if not b then act else do+ extra <- concatMap splitArgs . lines <$> readFile' ".ghcid"+ orig <- getArgs+ withArgs (extra ++ orig) act+++data TermSize = TermSize+ {termWidth :: Int+ ,termHeight :: Maybe Int -- ^ Nothing means the height is unlimited+ ,termWrap :: WordWrap+ }++-- | On the 'UnexpectedExit' exception exit with a nice error message.+handleErrors :: IO () -> IO ()+handleErrors = handle $ \(UnexpectedExit cmd _ mmsg) -> do+ logErr $ "Command \"" ++ cmd ++ "\" exited unexpectedly" ++ case mmsg of+ Just msg -> " with error message: " ++ msg+ Nothing -> ""+ exitFailure++printStopped :: Options -> IO ()+printStopped opts =+ forM_ (outputfile opts) $ \file -> do+ writeFile file "Ghcid has stopped.\n"+++-- | Like 'main', but run with a fake terminal for testing+mainWithTerminal :: IO TermSize -> ([String] -> IO ()) -> IO ()+mainWithTerminal termSize termOutput = do+ opts <- withGhcidArgs $ cmdArgsRun options+ logDebug $ "OS: " ++ os+ logDebug $ "ARCH: " ++ arch+ logDebug $ "VERSION: " ++ showVersion version+ args <- getArgs+ logDebug $ "ARGUMENTS: " ++ show args++ let withServerMaybe act+ | server opts = withServer (act . Just)+ | otherwise = act Nothing++ flip finally (printStopped opts) $ withServerMaybe (\serverEnv -> handleErrors $+ forever $ withWindowIcon $ withSession $ \session -> do+ -- Update the server's session reference on each (re)start+ mapM_ (`updateSession` session) serverEnv++ -- Collect type info for the :type-at, :loc-at, :uses, etc.+ let withDotGhci act = withSystemTempDirectory "ghcid" $ \dir -> do+ let dotGhci = dir </> ".ghci"+ writeFile dotGhci ":set +c"+ act dotGhci++ -- On certain Cygwin terminals stdout defaults to BlockBuffering+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr NoBuffering+ origDir <- getCurrentDirectory+ withCurrentDirectory (directory opts) $ withDotGhci $ \dotGhci -> do+ opts <- autoOptions opts dotGhci+ opts <- pure $ opts{restart = nubOrd $ (origDir </> ".ghcid") : restart opts, reload = nubOrd $ reload opts}+ when (topmost opts) terminalTopmost++ let noHeight = if no_height_limit opts then const Nothing else id+ termSize <- pure $ case (width opts, height opts) of+ (Just w, Just h) -> pure $ TermSize w (noHeight $ Just h) WrapHard+ (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+ pure $ TermSize+ (fromMaybe (pred $ termWidth term) w)+ (noHeight $ h <|> termHeight term)+ (if isJust w then WrapHard else termWrap term)++ restyle <- do+ useStyle <- case color opts of+ Always -> pure True+ Never -> pure False+ Auto -> hSupportsANSI stdout+ when useStyle $ do+ h <- lookupEnv "HSPEC_OPTIONS"+ when (isNothing h) $ setEnv "HSPEC_OPTIONS" "--color" -- see #87+ pure $ if useStyle then id else map unescape++ clear <- pure $+ if clear opts+ then (clearScreen *>)+ else id++ maybe withWaiterNotify withWaiterPoll (poll opts) $ \waiter ->+ runGhcid (if allow_eval opts then enableEval session else session) waiter termSize (clear . termOutput . restyle) opts serverEnv+ )++++main :: IO ()+main = mainWithTerminal termSize termOutput+ where+ termSize = do+ x <- Term.size+ pure $ case x of+ Nothing -> TermSize 80 (Just 8) WrapHard+ Just t -> TermSize (Term.width t) (Just $ Term.height t) WrapSoft++ termOutput xs = do+ outStr $ concatMap ('\n':) xs+ hFlush stdout -- must flush, since we don't finish with a newline+++data Continue = Continue++data ReloadMode = Reload | Restart deriving (Show, Ord, Eq)++-- If we return successfully, we restart the whole process+-- Use Continue not () so that inadvertent exits don't restart+runGhcid :: Session -> Waiter -> IO TermSize -> ([String] -> IO ()) -> Options -> Maybe ServerEnv -> IO Continue+runGhcid session waiter termSize termOutput opts@Options{..} serverEnv = do+ let limitMessages = maybe id (take . max 1) max_messages++ let outputFill :: String -> Maybe (Int, [Load]) -> [EvalResult] -> [String] -> IO ()+ outputFill currTime load evals msg = do+ load <- pure $ case load of+ Nothing -> []+ Just (loadedCount, msgs) -> prettyOutput currTime loadedCount (filter isMessage msgs) evals+ TermSize{..} <- termSize+ let wrap = concatMap (wordWrapE termWidth (termWidth `div` 5) . Esc)+ (msg, load, pad) <-+ case termHeight of+ Nothing -> pure (wrap msg, wrap load, [])+ Just termHeight -> do+ (termHeight, msg) <- pure $ takeRemainder termHeight $ wrap msg+ (termHeight, load) <-+ let takeRemainder' =+ if reverse_errors+ then -- When reversing the errors we want to crop out+ -- the top instead of the bottom of the load+ fmap reverse . takeRemainder termHeight . reverse+ else takeRemainder termHeight+ in pure $ takeRemainder' $ wrap load+ pure (msg, load, replicate termHeight "")+ let mergeSoft ((Esc x,WrapSoft):(Esc y,q):xs) = mergeSoft $ (Esc (x++y), q) : xs+ mergeSoft ((x,_):xs) = x : mergeSoft xs+ mergeSoft [] = []++ applyPadding x =+ if reverse_errors+ then pad ++ x+ else x ++ pad+ termOutput $ applyPadding $ map fromEsc ((if termWrap == WrapSoft then mergeSoft else map fst) $ load ++ msg)++ when (ignoreLoaded && null reload) $ do+ logErr "--reload must be set when using --ignore-loaded"+ exitFailure++ nextWait <- waitFiles waiter+ (messages, loaded) <- sessionStart session command $+ map (":set " ++) ghciFlagsUseful ++ setup++ when (null loaded && not ignoreLoaded) $ do+ logErr "No files loaded, meaning ghcid will never refresh, so aborting."+ logErr $ "Command: " ++ command+ exitFailure++ -- Update server with initial messages+ mapM_ (`updateMessages` messages) serverEnv++ restart <- pure $ nubOrd $ restart ++ [x | LoadConfig x <- messages, shouldWatchLoadConfig x]+ -- 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++ project <- if project /= "" then pure project else takeFileName <$> getCurrentDirectory++ -- fire, given a waiter, the messages/loaded/touched+ let+ fire+ :: ([(FilePath, ReloadMode)] -> IO (Either String [(FilePath, ReloadMode)]))+ -> ([Load], [FilePath], [FilePath])+ -> IO Continue+ fire nextWait (messages, loaded, touched) = do+ currTime <- getShortTime+ let loadedCount = length loaded+ logDebug $ "MESSAGES: " ++ show messages+ logDebug $ "LOADED: " ++ show loaded++ let evals = [e | Eval e <- messages]+ let (countErrors, countWarnings) = both sum $ unzip+ [if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []]+ let hasErrors = countErrors /= 0 || (countWarnings /= 0 && not warnings)+ test <- pure $+ if null test || hasErrors then Nothing+ else Just $ intercalate "\n" test++ unless no_title $ setWindowIcon $+ if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK++ 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") +++ " " ++ extra ++ [' ' | extra /= ""] ++ "- " ++ project++ updateTitle $ if isJust test then "(running test)" else ""++ -- 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+ moduleSorted = sortOn (Down . f) msgError ++ msgWarn+ pure $ (if reverse_errors then reverse else id) moduleSorted++ outputFill currTime (Just (loadedCount, 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 currTime loadedCount (limitMessages ordMessages) evals+ when (null loaded && not ignoreLoaded) $ do+ logErr "No files loaded, nothing to wait for. Fix the last error and restart."+ exitFailure+ whenJust test $ \t -> do+ logDebug $ "TESTING: " ++ t+ sessionExecAsync session t $ \stderr -> do+ logDebug "TESTING: Completed"+ hFlush stdout -- may not have been a terminating newline from test output+ if "*** Exception: " `isPrefixOf` stderr then do+ updateTitle "(test failed)"+ setWindowIcon IconError+ else do+ updateTitle "(test done)"+ whenNormal $ outStrLn "\n...done"+ whenJust lint $ \lintcmd ->+ unless hasErrors $ do+ (exitcode, stdout, stderr) <- readCreateProcessWithExitCode (shell . unwords $ lintcmd : map escape touched) ""+ unless (exitcode == ExitSuccess) $ do+ let output = stdout ++ stderr+ outStrLn output+ forM_ outputfile $ flip writeFile output++ reason <- nextWait $ map (,Restart) restart+ ++ map (,Reload) reload+ ++ map (,Reload) loaded++ let reason1 = case reason of+ Left err ->+ (Reload, ["Error when waiting, if this happens repeatedly, raise a ghcid bug.", err])+ Right files ->+ case partition (\(f, mode) -> mode == Reload) files of+ -- Prefer restarts over reloads. E.g., in case of both '--reload=dir'+ -- and '--restart=dir', ghcid would restart instead of reload.+ (_, rs@(_:_)) -> (Restart, map fst rs)+ (rl, _) -> (Reload, map fst rl)++ currTime <- getShortTime+ case reason1 of+ (Reload, reason2) -> do+ unless no_status $ outputFill currTime Nothing evals $ "Reloading..." : map (" " ++) reason2+ mapM_ setReloading serverEnv+ nextWait <- waitFiles waiter+ reloadResult <- sessionReload session+ mapM_ clearReloading serverEnv+ let (msgs, _, _) = reloadResult+ mapM_ (`updateMessages` msgs) serverEnv+ fire nextWait reloadResult+ (Restart, reason2) -> do+ -- exit cleanly, since the whole thing is wrapped in a forever+ unless no_status $ outputFill currTime Nothing evals $ "Restarting..." : map (" " ++) reason2+ pure Continue++ fire nextWait (messages, loaded, loaded)+++-- | 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 =+ (allGoodMessage ++ " (" ++ show loadedCount ++ " module" ++ ['s' | loadedCount /= 1] ++ ", at " ++ currTime ++ ")")+ : concatMap printEval evals+prettyOutput _ _ xs evals = concatMap loadMessage xs ++ concatMap printEval evals++printEval :: EvalResult -> [String]+printEval (EvalResult file (line, col) msg result) =+ [ " "+ , concat+ [ file+ , ":"+ , show line+ , ":"+ , show col+ ]+ ] ++ map ("$> " ++) (lines msg)+ ++ lines result+++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] ++ "}"
+ app/Language/Haskell/Ghcid/Terminal.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}++-- | Cross-platform operations for manipulating terminal console windows.+module Language.Haskell.Ghcid.Terminal(+ terminalTopmost,+ withWindowIcon, WindowIcon(..), setWindowIcon+ ) where++#if defined(mingw32_HOST_OS)+import Data.Word+import Data.Bits+import Control.Exception++import Graphics.Win32.Misc+import Graphics.Win32.Window+import Graphics.Win32.Message+import Graphics.Win32.GDI.Types+import System.Win32.Types+++wM_GETICON = 0x007F :: WindowMessage++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "windows.h GetConsoleWindow"+ getConsoleWindow :: IO HWND++foreign import CALLCONV unsafe "windows.h SetWindowPos"+ setWindowPos :: HWND -> HWND -> Int -> Int -> Int -> Int -> Word32 -> IO Bool+#endif+++-- | Raise the current terminal on top of all other screens, if you can.+terminalTopmost :: IO ()+#if defined(mingw32_HOST_OS)+terminalTopmost = do+ wnd <- getConsoleWindow+ setWindowPos wnd hWND_TOPMOST 0 0 0 0 (sWP_NOMOVE .|. sWP_NOSIZE)+ pure ()+#else+terminalTopmost = pure ()+#endif+++data WindowIcon = IconOK | IconWarning | IconError++-- | Change the window icon to green, yellow or red depending on whether the file was errorless, contained only warnings or contained at least one error.+setWindowIcon :: WindowIcon -> IO ()+#if defined(mingw32_HOST_OS)+setWindowIcon x = do+ ico <- pure $ case x of+ IconOK -> iDI_ASTERISK+ IconWarning -> iDI_EXCLAMATION+ IconError -> iDI_HAND+ icon <- loadIcon Nothing ico+ wnd <- getConsoleWindow+ -- SMALL is the system tray, BIG is the taskbar and Alt-Tab screen+ sendMessage wnd wM_SETICON iCON_SMALL $ fromIntegral $ castPtrToUINTPtr icon+ sendMessage wnd wM_SETICON iCON_BIG $ fromIntegral $ castPtrToUINTPtr icon+ pure ()+#else+setWindowIcon _ = pure ()+#endif+++-- | Run an operation in which you call setWindowIcon+withWindowIcon :: IO a -> IO a+#if defined(mingw32_HOST_OS)+withWindowIcon act = do+ wnd <- getConsoleWindow+ icoBig <- sendMessage wnd wM_GETICON iCON_BIG 0+ icoSmall <- sendMessage wnd wM_GETICON iCON_SMALL 0+ act `finally` do+ sendMessage wnd wM_SETICON iCON_BIG icoBig+ sendMessage wnd wM_SETICON iCON_SMALL icoSmall+ pure ()+#else+withWindowIcon act = act+#endif
+ app/Server.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Server+ ( ServerEnv (..),+ withServer,+ setReloading,+ clearReloading,+ updateMessages,+ updateSession,+ rewriteRequestForGhci,+ rewriteResponseFromGhci,+ )+where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.Extra+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Base64.URL as B64URL+import qualified Data.ByteString.Char8 as BS+import Data.List (isInfixOf, isPrefixOf, stripPrefix)+import Data.IORef+import Data.Maybe (fromMaybe)+import qualified Data.Aeson.Micro as JSON+import Data.Aeson.Micro ((.=), (.:))+import qualified Data.Text as T+import Language.Haskell.Ghcid.Escape (unescape)+import Language.Haskell.Ghcid.Types+import Network.Socket+import qualified Network.Socket.ByteString as NBS+import Session (PathMode (..), Session, sessionCurrentDir, sessionExec, sessionPathMode)+import System.Directory+import System.FilePath+import System.Info (os)+import Crypto.Hash.SHA256+import Language.Haskell.Ghcid.Util+#if MIN_VERSION_base(4,14,0)+import System.IO.Error (isResourceVanishedError)+#endif+import System.IO.Unsafe (unsafePerformIO)++data ServerEnv = ServerEnv+ { seSession :: IORef Session,+ seLock :: Lock,+ seReloading :: Var Bool,+ seMessages :: MVar [Load],+ seClients :: Var [Socket]+ }++newServerEnv :: IO ServerEnv+newServerEnv = do+ sessionRef <- newIORef (error "Session not initialized")+ lock <- newLock+ reloading <- newVar False+ messages <- newEmptyMVar+ clients <- newVar []+ pure+ ServerEnv+ { seSession = sessionRef,+ seLock = lock,+ seReloading = reloading,+ seMessages = messages,+ seClients = clients+ }++updateSession :: ServerEnv -> Session -> IO ()+updateSession ServerEnv {..} = writeIORef seSession++setReloading :: ServerEnv -> IO ()+setReloading ServerEnv {..} = writeVar seReloading True++clearReloading :: ServerEnv -> IO ()+clearReloading ServerEnv {..} = writeVar seReloading False++updateMessages :: ServerEnv -> [Load] -> IO ()+updateMessages env@ServerEnv {..} msgs = do+ inserted <- tryPutMVar seMessages msgs+ unless inserted $ void $ swapMVar seMessages msgs+ broadcastDiagnostics env (renderDiagnostics msgs)++withServer :: (ServerEnv -> IO a) -> IO a+withServer act = do+ env <- newServerEnv+ createDirectoryIfMissing True socketDir+ other <- canConnect serverSocketPath+ weClose <- newIORef False+ if other+ then do+ logInfo $ "withServer: Another ghcid server is already running at " ++ serverSocketPath+ act env+ else do+ removeIfExists serverSocketPath+ withListenServerSocket env $ \sock -> do++ let serverLoop = forever $ do+ (conn, _) <- accept sock+ logDebug "withServer: Accepted socket connection"+ void $ async $ handle+ (\(e :: SomeException) ->+ if isExpectedDisconnect e+ then logDebug $ "withServer: Client disconnected: " ++ show e+ else do+ weClosed <- readIORef weClose+ if weClosed+ then logDebug $ "withServer: Ignoring error after shutdown: " ++ show e+ else logErr $ "withServer: Socket session crashed: " ++ show e)+ (serveClient env conn `finally` (do+ close conn+ logDebug "withServer: Closed socket connection"+ ))++ mask $ \restore -> do+ serverAsync <- async serverLoop+ let shutdownServerLoop = do+ writeIORef weClose True+ ignored $ close sock+ cancel serverAsync+ void $ waitCatch serverAsync+ flip finally shutdownServerLoop $ do+ restore (act env)++{-# NOINLINE socketDir #-}+socketDir :: FilePath+socketDir = unsafePerformIO $ do+ -- Prefer /tmp over long $TMPDIR on mac to avoid socket length limit+ tmp <- (if os == "mingw32" then getTemporaryDirectory else pure "/tmp/ghcid")+ cwd <- getCurrentDirectory+ let digest = hash (BS.pack cwd)+ let shortHash = BS.unpack $ BS.take 8 $ B64URL.encodeUnpadded digest+ pure $ tmp </> shortHash++{-# NOINLINE serverSocketPath #-}+serverSocketPath :: FilePath+serverSocketPath = socketDir </> "server.sock"++withListenServerSocket :: ServerEnv -> (Socket -> IO a) -> IO a+withListenServerSocket env =+ bracket acquire release+ where+ acquire = do+ s <- socket AF_UNIX Stream defaultProtocol+ bind s (SockAddrUnix serverSocketPath)+ listen s 8+ pure s++ release sock = do+ clients <- readVar $ seClients env+ mapM_ (ignored . close) clients+ ignored $ close sock+ removeIfExists serverSocketPath++removeIfExists :: FilePath -> IO ()+removeIfExists p = removeFile p `catch` (\(_ :: IOException) -> pure ())++canConnect :: FilePath -> IO Bool+canConnect path = do+ result <- try $ bracket (socketConnect path) close (const $ pure ())+ pure $ case result of+ Right () -> True+ Left (_ :: IOException) -> False++socketConnect :: FilePath -> IO Socket+socketConnect path = do+ s <- socket AF_UNIX Stream defaultProtocol+ connect s (SockAddrUnix path)+ pure s++isExpectedDisconnect :: SomeException -> Bool+isExpectedDisconnect e =+ case fromException e :: Maybe IOException of+ Just ioe+ | isResourceVanishedErrorCompat ioe -> True+ | otherwise -> False+ Nothing -> False++isResourceVanishedErrorCompat :: IOError -> Bool+#if MIN_VERSION_base(4,14,0)+isResourceVanishedErrorCompat = isResourceVanishedError+#else+isResourceVanishedErrorCompat _ = False+#endif++serveClient :: ServerEnv -> Socket -> IO ()+serveClient env@ServerEnv {..} sock = do+ bracket_+ (modifyVar_ seClients $ pure . (sock :))+ (modifyVar_ seClients $ pure . filter (/= sock))+ $ do+ initial <- renderDiagnostics <$> readMVar seMessages+ sendLine sock "diag" initial+ loop BS.empty+ where+ loop pending = do+ (line, rest) <- recvLine sock pending+ case line of+ Nothing -> logDebug "Client disconnected"+ Just raw -> handleLine raw >> loop rest++ handleLine raw = case parseRequestLine raw of+ Left err -> sendLine sock "err" err+ Right cmd -> do+ logDebug $ "client->server " ++ BS.unpack raw+ result <- execGhci env cmd+ case result of+ Left err -> sendLine sock "err" err+ Right out -> sendLine sock "stdout" out++recvLine :: Socket -> BS.ByteString -> IO (Maybe BS.ByteString, BS.ByteString)+recvLine sock pending =+ case BS.break (== '\n') pending of+ (line, rest)+ | not (BS.null rest) -> pure (Just line, BS.drop 1 rest)+ | otherwise -> do+ chunk <- NBS.recv sock 4096+ if BS.null chunk+ then+ if BS.null pending+ then pure (Nothing, BS.empty)+ else pure (Just pending, BS.empty)+ else recvLine sock (pending <> chunk)++parseRequestLine :: BS.ByteString -> Either String String+parseRequestLine line = do+ let Nothing <?> a = Left a+ Just b <?> _ = Right b++ let parseRequest = JSON.withObject "Request" $ \obj -> do+ typ <- obj .: "type"+ payload <- obj .: "payload"+ if typ == "stdin"+ then pure (T.unpack payload)+ else fail $ "Unsupported message type: " ++ T.unpack typ++ value <- JSON.decodeStrict line <?> "Invalid JSON"++ JSON.parseMaybe parseRequest value <?> "Invalid request payload"++sendLine :: Socket -> T.Text -> String -> IO ()+sendLine sock tag payload = do+ let o = JSON.encodeStrict (JSON.object ["type" .= tag, "payload" .= T.pack payload]) <> "\n"+ logDebug $ "server->client " ++ BS.unpack o+ NBS.sendAll sock o+++execGhci :: ServerEnv -> String -> IO (Either String String)+execGhci ServerEnv {..} cmd = do+ reloading <- readVar seReloading+ if reloading+ then do+ logDebug "Rejecting request because reload is in progress"+ pure $ Left "Reload in progress"+ else do+ result <- withLock seLock $ try $ do+ session <- readIORef seSession+ projectDir <- sessionCurrentDir session+ mode <- sessionPathMode session+ let rewrittenCmd = rewriteRequestForGhci mode projectDir cmd+ ls <- sessionExec session rewrittenCmd+ pure $ rewriteResponseFromGhci mode projectDir ls+ case result of+ Left (e :: SomeException) -> do+ logErr $ "sessionExec threw: " ++ show e+ pure $ Left (show e)+ Right ls -> pure $ Right (unlines ls)++rewriteRequestForGhci :: PathMode -> FilePath -> String -> String+rewriteRequestForGhci mode projectDir cmd =+ if mode == PathRelative+ then foldr rewrite cmd [":type-at", ":loc-at", ":uses"]+ else cmd+ where+ rewrite prefix acc =+ fromMaybe acc $ do+ rest <- stripPrefix (prefix ++ " " ++ addTrailingPathSeparator projectDir) acc+ pure $ prefix ++ " " ++ rest++rewriteResponseFromGhci :: PathMode -> FilePath -> [String] -> [String]+rewriteResponseFromGhci mode projectDir+ | mode == PathRelative = map (rewriteLocationLine projectDir)+ | otherwise = id++rewriteLocationLine :: FilePath -> String -> String+rewriteLocationLine projectDir line =+ if looksRelativeLocation line+ then projectDir </> line+ else line+ where+ looksRelativeLocation x =+ not (null x)+ && not (isAbsolute x)+ && not ("<" `isPrefixOf` x)+ && any (`isInfixOf` x) [".hs:", ".lhs:", ".hs-boot:"]++renderDiagnostics :: [Load] -> String+renderDiagnostics msgs =+ case [unescape line | Message {loadMessage = ls} <- msgs, line <- ls] of+ [] -> "All good (0 modules)\n"+ ls -> unlines ls++broadcastDiagnostics :: ServerEnv -> String -> IO ()+broadcastDiagnostics ServerEnv {..} payload = do+ clients <- readVar seClients+ forM_ clients $ \sock -> do+ result <- try $ sendLine sock "diag" payload+ case result of+ Left (e :: IOException) -> do+ logDebug $ "Failed to push diag to client: " ++ show e+ Right () -> pure ()
+ app/Session.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE RecordWildCards #-}++-- | A persistent version of the Ghci session, encoding lots of semantics on top.+-- Not suitable for calling multithreaded.+module Session(+ Session, PathMode(..), enableEval, withSession,+ sessionStart, sessionReload,+ sessionExecAsync, sessionExec, sessionCurrentDir, sessionPathMode,+ ) 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.Console.ANSI+import System.Time.Extra+import System.Process+import System.FilePath+import Control.Exception.Extra+import Control.Concurrent.Extra+import Control.Monad.Extra+import Data.Maybe+import Data.List.Extra+import Control.Applicative+import Prelude+import System.IO.Extra+import System.Console.CmdArgs.Verbosity+++data Session = Session+ {ghci :: IORef (Maybe Ghci) -- ^ The Ghci session, or Nothing if there is none+ ,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+ ,pathMode :: IORef PathMode -- ^ Whether GHCi reports modules using relative or absolute paths+ ,running :: Var Bool -- ^ Am I actively running an async command+ ,withThread :: ThreadId -- ^ Thread that called withSession+ ,allowEval :: Bool -- ^ Is the allow-eval flag set?+ }++data PathMode = PathRelative | PathAbsolute | PathUnknown+ deriving (Eq, Show)++enableEval :: Session -> Session+enableEval s = s { allowEval = True }++-- | The function 'withSession' expects to be run on the main thread,+-- but the inner function will not. This ensures Ctrl-C is handled+-- properly and any spawned Ghci processes will be aborted.+withSession :: (Session -> IO a) -> IO a+withSession f = do+ ghci <- newIORef Nothing+ command <- newIORef Nothing+ warnings <- newIORef []+ curdir <- newIORef "."+ pathMode <- newIORef PathUnknown+ running <- newVar False+ logDebug "Starting session"+ withThread <- myThreadId+ let allowEval = False+ f Session{..} `finally` do+ logDebug "Start finally"+ modifyVar_ running $ const $ pure False+ whenJustM (readIORef ghci) $ \v -> do+ writeIORef ghci Nothing+ logDebug "Calling kill"+ kill v+ logDebug "Finish finally"+++-- | Kill immediately.+kill :: Ghci -> IO ()+kill ghci = ignored $ do+ logDebug "Before killProcessGroup"+ ignored $ killProcessGroup $ process ghci+ logDebug "After killProcessGroup"+ -- Ctrl-C after a tests keeps the cursor hidden,+ -- `setSGR []`didn't seem to be enough+ -- See: https://github.com/ndmitchell/ghcid/issues/254+ showCursor++loadedModules :: FilePath -> [Load] -> [FilePath]+loadedModules dir = nubOrd . map (loadFile . qualify dir) . filter predicate+ where+ predicate Message{loadFile = loadFile} = loadFile /= "<unknown>"+ predicate Loading{loadFile = loadFile} = loadFile /= "<unknown>"+ predicate _ = False++qualify :: FilePath -> Load -> Load+qualify dir message = message{loadFile = dir </> loadFile message}++determinePathMode :: [FilePath] -> PathMode+determinePathMode (x:_)+ | isAbsolute x = PathAbsolute+ | otherwise = PathRelative+determinePathMode [] = PathUnknown++-- | 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 -> [String] -> IO ([Load], [FilePath])+sessionStart Session{..} cmd setup = do+ modifyVar_ running $ const $ pure False+ writeIORef command $ Just (cmd, setup)++ -- cleanup any old instances+ whenJustM (readIORef ghci) $ \v -> do+ writeIORef ghci Nothing+ void $ forkIO $ kill v++ -- start the new+ logInfo $ "Starting ghci command: " ++ cmd+ (v, messages) <- mask $ \unmask -> do+ (v, messages) <- unmask $ startGhci cmd Nothing $ \_ msg -> whenNormal $ outStrLn msg+ writeIORef ghci $ Just v+ pure (v, messages)++ -- do whatever preparation was requested+ exec v $ unlines setup++ -- deal with current directory+ (dir, _) <- showPaths v+ moduleFiles <- map snd <$> showModules v+ writeIORef curdir dir+ writeIORef pathMode $ determinePathMode moduleFiles+ messages <- pure $ map (qualify dir) messages++ let loaded = loadedModules dir messages+ evals <- performEvals v allowEval loaded++ -- install a handler+ forkIO $ do+ code <- waitForProcess $ process v+ whenJustM (readIORef ghci) $ \ghci ->+ when (ghci == v) $ do+ sleep 0.3 -- give anyone reading from the stream a chance to throw first+ throwTo withThread $ ErrorCall $ "Command \"" ++ cmd ++ "\" exited unexpectedly with " ++ show code++ -- handle what the process returned+ messages <- pure $ mapMaybe tidyMessage messages+ writeIORef warnings $ getWarnings messages+ pure (messages ++ evals, loaded)+++getWarnings :: [Load] -> [Load]+getWarnings messages = [m | m@Message{..} <- messages, loadSeverity == Warning]+++-- | Call 'sessionStart' at the previous command.+sessionRestart :: Session -> IO ([Load], [FilePath])+sessionRestart session@Session{..} = do+ Just (cmd, setup) <- readIORef command+ sessionStart session cmd setup+++performEvals :: Ghci -> Bool -> [FilePath] -> IO [Load]+performEvals _ False _ = pure []+performEvals ghci True reloaded = do+ cmds <- mapM getCommands reloaded+ fmap join $ forM cmds $ \(file, cmds') ->+ forM cmds' $ \(num, cmd) -> do+ ref <- newIORef []+ execStream ghci cmd $ \_ resp -> modifyIORef ref (resp :)+ resp <- unlines . reverse <$> readIORef ref+ pure $ Eval $ EvalResult file (num, 1) cmd resp+++getCommands :: FilePath -> IO (FilePath, [(Int, String)])+getCommands fp = do+ ls <- readFileUTF8' fp+ pure (fp, splitCommands $ zipFrom 1 $ lines ls)++splitCommands :: [(Int, String)] -> [(Int, String)]+splitCommands [] = []+splitCommands ((num, line) : ls)+ | isCommand line =+ let (cmds, xs) = span (isCommand . snd) ls+ in (num, unwords $ fmap (drop $ length commandPrefix) $ line : fmap snd cmds) : splitCommands xs+ | isMultilineCommandPrefix line =+ let (cmds, xs) = break (isMultilineCommandSuffix . snd) ls+ in (num, unlines (wrapGhciMultiline (fmap snd cmds))) : splitCommands (drop1 xs)+ | otherwise = splitCommands ls++isCommand :: String -> Bool+isCommand = isPrefixOf commandPrefix++commandPrefix :: String+commandPrefix = "-- $> "++isMultilineCommandPrefix :: String -> Bool+isMultilineCommandPrefix = (==) multilineCommandPrefix++multilineCommandPrefix :: String+multilineCommandPrefix = "{- $>"++isMultilineCommandSuffix :: String -> Bool+isMultilineCommandSuffix = (==) multilineCommandSuffix++multilineCommandSuffix :: String+multilineCommandSuffix = "<$ -}"++wrapGhciMultiline :: [String] -> [String]+wrapGhciMultiline xs = [":{"] ++ xs ++ [":}"]++-- | Reload, returning the same information as 'sessionStart'. In particular, any+-- information that GHCi doesn't repeat (warnings from loaded modules) will be+-- added back in.+sessionReload :: Session -> IO ([Load], [FilePath], [FilePath])+sessionReload session@Session{..} = do+ -- kill anything async, set stuck if you didn't succeed+ old <- modifyVar running $ \b -> pure (False, b)+ stuck <- if not old then pure False else do+ Just ghci <- readIORef ghci+ fmap isNothing $ timeout 5 $ interrupt ghci++ if stuck+ then (\(messages,loaded) -> (messages,loaded,loaded)) <$> sessionRestart session+ else do+ -- actually reload+ Just ghci <- readIORef ghci+ dir <- readIORef curdir+ messages <- mapMaybe tidyMessage <$> reload ghci+ shownModules <- showModules ghci+ writeIORef pathMode $ determinePathMode $ map snd shownModules+ let loaded = map ((dir </>) . snd) shownModules+ let reloaded = loadedModules dir messages+ warn <- readIORef warnings+ evals <- performEvals ghci allowEval reloaded++ -- only keep old warnings from files that are still loaded, but did not reload+ let validWarn w = loadFile w `elem` loaded && loadFile w `notElem` reloaded+ -- newest warnings always go first, so the file you hit save on most recently has warnings first+ messages <- pure $ messages ++ filter validWarn warn++ writeIORef warnings $ getWarnings messages+ pure (messages ++ evals, nubOrd (loaded ++ reloaded), reloaded)+++-- | Run an exec operation asynchronously. Should not be a @:reload@ or similar.+-- Will be automatically aborted if it takes too long. Only fires done if not aborted.+-- Argument to done is the final stderr line.+sessionExecAsync :: Session -> String -> (String -> IO ()) -> IO ()+sessionExecAsync Session{..} cmd done = do+ Just ghci <- readIORef ghci+ stderr <- newIORef ""+ modifyVar_ running $ const $ pure True+ caller <- myThreadId+ void $ flip forkFinally (either (throwTo caller) (const $ pure ())) $ do+ execStream ghci cmd $ \strm msg ->+ when (msg /= "*** Exception: ExitSuccess") $ do+ when (strm == Stderr) $ writeIORef stderr msg+ whenNormal $ outStrLn msg+ old <- modifyVar running $ \b -> pure (False, b)+ -- don't fire Done if someone interrupted us+ stderr <- readIORef stderr+ when old $ done stderr+++-- | Execute a GHCi command synchronously, returning the output lines.+sessionExec :: Session -> String -> IO [String]+sessionExec Session{..} cmd = do+ mghci <- readIORef ghci+ case mghci of+ Nothing -> pure ["GHCi session not available"]+ Just g -> exec g cmd++sessionCurrentDir :: Session -> IO FilePath+sessionCurrentDir Session{..} = readIORef curdir++sessionPathMode :: Session -> IO PathMode+sessionPathMode Session{..} = readIORef pathMode+++-- | Ignore entirely pointless messages and remove unnecessary lines.+tidyMessage :: Load -> Maybe Load+tidyMessage Message{loadSeverity=Warning, loadMessage=[_,x]}+ | unescape x == " -O conflicts with --interactive; -O ignored." = Nothing+tidyMessage m@Message{..}+ = 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
+ app/Wait.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | Use 'withWaiterPoll' or 'withWaiterNotify' to create a 'Waiter' object,+-- then access it (single-threaded) by using 'waitFiles'.+module Wait(Waiter, withWaiterPoll, withWaiterNotify, waitFiles) where++import Control.Concurrent.Extra+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad.Extra+import Data.List.Extra+import System.FilePath+import Control.Exception.Extra+import System.Directory.Extra+import Data.Time.Clock+import Data.String+import System.Time.Extra+import System.FSNotify+import Language.Haskell.Ghcid.Util+++data Waiter+ = WaiterPoll Seconds+ | WaiterNotify WatchManager (MVar ()) (Var (Map.Map FilePath StopListening))++withWaiterPoll :: Seconds -> (Waiter -> IO a) -> IO a+withWaiterPoll x f = f $ WaiterPoll x++withWaiterNotify :: (Waiter -> IO a) -> IO a+withWaiterNotify f = withManagerConf defaultConfig $ \manager -> do+ mvar <- newEmptyMVar+ var <- newVar Map.empty+ f $ WaiterNotify manager mvar var++-- `listContentsInside test dir` will list files and directories inside `dir`,+-- recursing into those subdirectories which pass `test`.+-- Note that `dir` and files it directly contains are always listed, regardless of `test`.+-- Subdirectories will have a trailing path separator, and are only listed if we recurse into them.+listContentsInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]+listContentsInside test dir = do+ (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir+ recurse <- filterM test dirs+ rest <- concatMapM (listContentsInside test) recurse+ pure $ addTrailingPathSeparator dir : files ++ rest++-- | Given the pattern:+--+-- > wait <- waitFiles waiter+-- > ...+-- > wait ["File1.hs","File2.hs"]+--+-- This continues as soon as either @File1.hs@ or @File2.hs@ changes,+-- starting from when 'waitFiles' was initially called.+--+-- returns a message about why you are continuing (usually a file name).+waitFiles :: forall a. Ord a => Waiter -> IO ([(FilePath, a)] -> IO (Either String [(FilePath, a)]))+waitFiles waiter = do+ base <- getCurrentTime+ pure $ \files -> handle onError (go base files)+ where+ onError :: IOError -> IO (Either String [(FilePath, a)])+ onError e = sleep 1.0 >> pure (Left (show e))++ go :: UTCTime -> [(FilePath, a)] -> IO (Either String [(FilePath, a)])+ go base files = do+ logDebug $ "WAITING: " ++ unwords (map fst files)+ -- As listContentsInside returns directories, we are waiting on them explicitly and so+ -- will pick up new files, as creating a new file changes the containing directory's modtime.+ files <- concatForM files $ \(file, a) ->+ ifM (doesDirectoryExist file) (fmap (,a) <$> listContentsInside (pure . not . isPrefixOf "." . takeFileName) file) (pure [(file, a)])+ case waiter of+ WaiterPoll t -> pure ()+ WaiterNotify manager kick mp -> do+ dirs <- fmap Set.fromList $ mapM canonicalizePathSafe $ nubOrd $ map (takeDirectory . fst) files+ modifyVar_ mp $ \mp -> do+ let (keep,del) = Map.partitionWithKey (\k v -> k `Set.member` dirs) mp+ sequence_ $ Map.elems del+ new <- forM (Set.toList $ dirs `Set.difference` Map.keysSet keep) $ \dir -> do+ can <- watchDir manager (fromString dir) (const True) $ \event -> do+ logDebug $ "NOTIFY: " ++ show event+ void $ tryPutMVar kick ()+ pure (dir, can)+ let mp2 = keep `Map.union` Map.fromList new+ logDebug $ "WAITING: " ++ unwords (Map.keys mp2)+ pure mp2+ void $ tryTakeMVar kick+ new <- mapM (getModTime . fst) files+ case [x | (x,Just t) <- zip files new, t > base] of+ [] -> Right <$> recheck files new+ xs -> pure (Right xs)++ recheck :: [(FilePath, a)] -> [Maybe UTCTime] -> IO [(String, a)]+ recheck files old = do+ sleep 0.1+ case waiter of+ WaiterPoll t -> sleep $ max 0 $ t - 0.1 -- subtract the initial 0.1 sleep from above+ WaiterNotify _ kick _ -> do+ takeMVar kick+ logDebug "WAITING: Notify signaled"+ new <- mapM (getModTime . fst) files+ case [x | (x,t1,t2) <- zip3 files old new, t1 /= t2] of+ [] -> recheck files new+ xs -> do+ let disappeared = [x | (x, Just _, Nothing) <- zip3 files old new]+ unless (null disappeared) $ do+ -- if someone is deleting a needed file, give them some space to put the file back+ -- typically caused by VIM+ -- but try not to+ logDebug $ "WAITING: Waiting max of 1s due to file removal, " ++ unwords (nubOrd (map fst disappeared))+ -- at most 20 iterations, but stop as soon as the file returns+ void $ flip firstJustM (replicate 20 ()) $ \_ -> do+ sleep 0.05+ new <- mapM (getModTime . fst) files+ pure $ if null [x | (x, Just _, Nothing) <- zip3 files old new] then Just () else Nothing+ pure xs+++canonicalizePathSafe :: FilePath -> IO FilePath+canonicalizePathSafe x = canonicalizePath x `catch` \(_ :: IOError) -> pure x
ghcid.cabal view
@@ -1,19 +1,19 @@ cabal-version: 1.18 build-type: Simple name: ghcid-version: 0.8.9+version: 1.0.0 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com>, jpmoresmau maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2014-2023+copyright: Neil Mitchell 2014-2026 synopsis: GHCi based bare bones IDE description: 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==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8+tested-with: GHC==9.12, GHC==9.10, GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8 extra-doc-files: CHANGES.txt README.md@@ -34,6 +34,9 @@ process >= 1.1, ansi-terminal, cmdargs >= 0.10+ if !os(windows)+ build-depends:+ unix exposed-modules: Language.Haskell.Ghcid@@ -45,7 +48,7 @@ Language.Haskell.Ghcid.Util executable ghcid- hs-source-dirs: src+ hs-source-dirs: app, src default-language: Haskell2010 ghc-options: -main-is Ghcid.main -threaded -rtsopts main-is: Ghcid.hs@@ -57,10 +60,18 @@ containers, fsnotify >= 0.4, extra >= 1.6.20,+ async, process >= 1.1, cmdargs >= 0.10, ansi-terminal,- terminal-size >= 0.3+ terminal-size >= 0.3,+ temporary,+ network,+ cryptohash-sha256,+ bytestring,+ base64-bytestring,+ text,+ microaeson if os(windows) build-depends: Win32 >= 2.13.2.1 else@@ -73,12 +84,13 @@ Language.Haskell.Ghcid.Util Language.Haskell.Ghcid Paths_ghcid+ Server Session Wait test-suite ghcid_test type: exitcode-stdio-1.0- hs-source-dirs: src+ hs-source-dirs: test, app, src main-is: Test.hs ghc-options: -rtsopts -main-is Test.main -threaded -with-rtsopts=-K1K default-language: Haskell2010@@ -91,8 +103,16 @@ containers, fsnotify >= 0.4, extra >= 1.6.6,+ async, ansi-terminal, terminal-size >= 0.3,+ temporary,+ bytestring,+ network,+ cryptohash-sha256,+ base64-bytestring,+ text,+ microaeson, cmdargs, tasty, tasty-hunit@@ -109,6 +129,7 @@ Language.Haskell.Ghcid.Types Language.Haskell.Ghcid.Util Paths_ghcid+ Server Session Test.API Test.Common
− src/Ghcid.hs
@@ -1,477 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, TupleSections #-}-{-# OPTIONS_GHC -fno-cse #-}---- | The application entry point-module Ghcid(main, mainWithTerminal, TermSize(..), WordWrap(..)) where--import Control.Exception-import System.IO.Error-import Control.Applicative-import Control.Monad.Extra-import Data.List.Extra-import Data.Maybe-import Data.Ord-import Data.Tuple.Extra-import Data.Version-import Session-import qualified System.Console.Terminal.Size as Term-import System.Console.CmdArgs-import System.Console.CmdArgs.Explicit-import System.Console.ANSI-import System.Environment-import System.Directory.Extra-import System.Time.Extra-import System.Exit-import System.FilePath-import System.Process-import System.Info-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-import Wait--import Prelude----- | Command line options-data Options = Options- {command :: String- ,arguments :: [String]- ,test :: [String]- ,test_message :: String- ,run :: [String]- ,warnings :: Bool- ,lint :: Maybe String- ,no_status :: Bool- ,clear :: Bool- ,reverse_errors :: Bool- ,no_height_limit :: Bool- ,height :: Maybe Int- ,width :: Maybe Int- ,topmost :: Bool- ,no_title :: Bool- ,project :: String- ,reload :: [FilePath]- ,restart :: [FilePath]- ,directory :: FilePath- ,outputfile :: [FilePath]- ,ignoreLoaded :: Bool- ,poll :: Maybe Seconds- ,max_messages :: Maybe Int- ,color :: ColorMode- ,setup :: [String]- ,allow_eval :: Bool- ,target :: [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 = "" &= 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"- ,test_message = "Running test..." &= typ "MESSAGE" &= help "Message to show before running the test (defaults to \"Running test...\")"- ,run = [] &= name "r" &= typ "EXPR" &= opt "main" &= help "Command to run after successful loading (like --test but defaults to main)"- ,warnings = False &= name "W" &= help "Allow tests to run even with warnings"- ,lint = Nothing &= typ "COMMAND" &= name "lint" &= opt "hlint" &= help "Linter to run if there are no errors. Defaults to hlint."- ,no_status = False &= name "S" &= help "Suppress status messages"- ,clear = False &= name "clear" &= help "Clear screen when reloading"- ,reverse_errors = False &= help "Reverse output order (works best with --no-height-limit)"- ,no_height_limit = False &= name "no-height-limit" &= help "Disable height limit"- ,height = Nothing &= help "Number of lines to use (defaults to console height)"- ,width = Nothing &= name "w" &= help "Number of columns to use (defaults to console width)"- ,topmost = False &= name "t" &= help "Set window topmost (Windows only)"- ,no_title = False &= help "Don't update the shell title/icon"- ,project = "" &= typ "NAME" &= help "Name of the project, defaults to current directory"- ,restart = [] &= typ "PATH" &= help "Restart the command when the given file or directory contents change (defaults to .ghci and any .cabal file, unless when using stack or a custom command)"- ,reload = [] &= typ "PATH" &= help "Reload when the given file or directory contents change (defaults to none)"- ,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."- ,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>"- ,allow_eval = False &= name "allow-eval" &= help "Execute REPL commands in comments"- ,target = [] &= typ "TARGET" &= help "Target Component to build (e.g. lib:foo for Cabal, foo:lib for Stack)"- } &= verbosity &=- program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version)---{--What happens on various command lines:--Hlint with no .ghci file:-- cabal repl - prompt with Language.Haskell.HLint loaded-- cabal exec ghci Sample.hs - prompt with Sample.hs loaded-- ghci - prompt with nothing loaded-- ghci Sample.hs - prompt with Sample.hs loaded-- stack ghci - prompt with all libraries and Main loaded--Hlint with a .ghci file:-- cabal repl - loads everything twice, prompt with Language.Haskell.HLint loaded-- cabal exec ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded-- ghci - prompt with everything-- ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded-- stack ghci - loads everything first, then prompt with libraries and Main loaded--Warnings:-- cabal repl won't pull in any C files (e.g. hoogle)-- cabal exec ghci won't work with modules that import an autogen Paths module--As a result, we prefer to give users full control with a .ghci file, if available--}-autoOptions :: Options -> IO Options-autoOptions o@Options{..}- | command /= "" = pure $ f [command] []- | otherwise = do- curdir <- getCurrentDirectory- files <- getDirectoryContents "."-- -- use unsafePerformIO to get nicer pattern matching for logic (read-only operations)- let findStack dir = flip catchIOError (const $ pure Nothing) $ do- let yaml = dir </> "stack.yaml"- b <- doesFileExist yaml &&^ doesDirectoryExist (dir </> ".stack-work")- pure $ if b then Just yaml else Nothing- stackFile <- firstJustM findStack [".",".."] -- stack file might be parent, see #62-- let cabal = map (curdir </>) $ filter ((==) ".cabal" . takeExtension) files- let isLib = isPrefixOf "lib:" -- `lib:foo` is the Cabal format- let noCode = [ "-fno-code"- | null test- && null run- && not allow_eval- && (isJust stackFile || all isLib target) ]- let opts = noCode ++ ghciFlagsRequired ++ ghciFlagsUseful- pure $ case () of- _ | Just stack <- stackFile ->- let flags = if null arguments then- "stack ghci" : target ++ "--test --bench" :- ["--no-load" | ".ghci" `elem` files] ++- map ("--ghci-options=" ++) opts- else- "stack exec --test --bench -- ghci" : opts- in f flags $ stack:cabal- | ".ghci" `elem` files -> f ("ghci":opts) [curdir </> ".ghci"]- | cabal /= [] ->- let useCabal = ["cabal","repl"] ++ target ++ map ("--repl-options=" ++) opts- useGhci = "cabal exec -- ghci":opts- in f (if null arguments then useCabal else useGhci) cabal- | otherwise -> f ("ghci":opts) []- where- f c r = o{command = unwords $ c ++ map escape arguments, arguments = [], restart = restart ++ r, run = [], test = run ++ test}---- | Simple escaping for command line arguments. Wraps a string in double quotes if it contains a space.-escape x | ' ' `elem` x = "\"" ++ x ++ "\""- | otherwise = x---- | Use arguments from .ghcid if present-withGhcidArgs :: IO a -> IO a-withGhcidArgs act = do- b <- doesFileExist ".ghcid"- if not b then act else do- extra <- concatMap splitArgs . lines <$> readFile' ".ghcid"- orig <- getArgs- withArgs (extra ++ orig) act---data TermSize = TermSize- {termWidth :: Int- ,termHeight :: Maybe Int -- ^ Nothing means the height is unlimited- ,termWrap :: WordWrap- }---- | On the 'UnexpectedExit' exception exit with a nice error message.-handleErrors :: IO () -> IO ()-handleErrors = handle $ \(UnexpectedExit cmd _ mmsg) -> do- putStr $ "Command \"" ++ cmd ++ "\" exited unexpectedly"- putStrLn $ case mmsg of- Just msg -> " with error message: " ++ msg- Nothing -> ""- exitFailure--printStopped :: Options -> IO ()-printStopped opts =- forM_ (outputfile opts) $ \file -> do- writeFile file "Ghcid has stopped.\n"----- | Like 'main', but run with a fake terminal for testing-mainWithTerminal :: IO TermSize -> ([String] -> IO ()) -> IO ()-mainWithTerminal termSize termOutput = do- opts <- withGhcidArgs $ cmdArgsRun options- whenLoud $ do- outStrLn $ "%OS: " ++ os- outStrLn $ "%ARCH: " ++ arch- outStrLn $ "%VERSION: " ++ showVersion version- args <- getArgs- outStrLn $ "%ARGUMENTS: " ++ show args- flip finally (printStopped opts) $ handleErrors $- forever $ withWindowIcon $ withSession $ \session -> do- setVerbosity Normal -- undo any --verbose flags-- -- On certain Cygwin terminals stdout defaults to BlockBuffering- hSetBuffering stdout LineBuffering- hSetBuffering stderr NoBuffering- origDir <- getCurrentDirectory- withCurrentDirectory (directory opts) $ do- opts <- autoOptions opts- opts <- pure $ opts{restart = nubOrd $ (origDir </> ".ghcid") : restart opts, reload = nubOrd $ reload opts}- when (topmost opts) terminalTopmost-- let noHeight = if no_height_limit opts then const Nothing else id- termSize <- pure $ case (width opts, height opts) of- (Just w, Just h) -> pure $ TermSize w (noHeight $ Just h) WrapHard- (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- pure $ TermSize- (fromMaybe (pred $ termWidth term) w)- (noHeight $ h <|> termHeight term)- (if isJust w then WrapHard else termWrap term)-- restyle <- do- useStyle <- case color opts of- Always -> pure True- Never -> pure False- Auto -> hSupportsANSI stdout- when useStyle $ do- h <- lookupEnv "HSPEC_OPTIONS"- when (isNothing h) $ setEnv "HSPEC_OPTIONS" "--color" -- see #87- pure $ if useStyle then id else map unescape-- clear <- pure $- if clear opts- then (clearScreen *>)- else id-- maybe withWaiterNotify withWaiterPoll (poll opts) $ \waiter ->- runGhcid (if allow_eval opts then enableEval session else session) waiter termSize (clear . termOutput . restyle) opts----main :: IO ()-main = mainWithTerminal termSize termOutput- where- termSize = do- x <- Term.size- pure $ case x of- Nothing -> TermSize 80 (Just 8) WrapHard- Just t -> TermSize (Term.width t) (Just $ Term.height t) WrapSoft-- termOutput xs = do- outStr $ concatMap ('\n':) xs- hFlush stdout -- must flush, since we don't finish with a newline---data Continue = Continue--data ReloadMode = Reload | Restart deriving (Show, Ord, Eq)---- If we return successfully, we restart the whole process--- Use Continue not () so that inadvertant exits don't restart-runGhcid :: Session -> Waiter -> IO TermSize -> ([String] -> IO ()) -> Options -> IO Continue-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 ()- outputFill currTime load evals msg = do- load <- pure $ case load of- Nothing -> []- Just (loadedCount, msgs) -> prettyOutput currTime loadedCount (filter isMessage msgs) evals- TermSize{..} <- termSize- let wrap = concatMap (wordWrapE termWidth (termWidth `div` 5) . Esc)- (msg, load, pad) <-- case termHeight of- Nothing -> pure (wrap msg, wrap load, [])- Just termHeight -> do- (termHeight, msg) <- pure $ takeRemainder termHeight $ wrap msg- (termHeight, load) <-- let takeRemainder' =- if reverse_errors- then -- When reversing the errors we want to crop out- -- the top instead of the bottom of the load- fmap reverse . takeRemainder termHeight . reverse- else takeRemainder termHeight- in pure $ takeRemainder' $ wrap load- pure (msg, load, replicate termHeight "")- let mergeSoft ((Esc x,WrapSoft):(Esc y,q):xs) = mergeSoft $ (Esc (x++y), q) : xs- mergeSoft ((x,_):xs) = x : mergeSoft xs- mergeSoft [] = []-- applyPadding x =- if reverse_errors- then pad ++ x- else x ++ pad- termOutput $ applyPadding $ map fromEsc ((if termWrap == WrapSoft then mergeSoft else map fst) $ load ++ 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, meaning ghcid will never refresh, so aborting.\nCommand: " ++ command- exitFailure-- restart <- pure $ 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-- project <- if project /= "" then pure project else takeFileName <$> getCurrentDirectory-- -- fire, given a waiter, the messages/loaded/touched- let- fire- :: ([(FilePath, ReloadMode)] -> IO (Either String [(FilePath, ReloadMode)]))- -> ([Load], [FilePath], [FilePath])- -> IO Continue- fire nextWait (messages, loaded, touched) = do- currTime <- getShortTime- let loadedCount = length loaded- whenLoud $ do- outStrLn $ "%MESSAGES: " ++ show messages- outStrLn $ "%LOADED: " ++ show loaded-- let evals = [e | Eval e <- messages]- let (countErrors, countWarnings) = both sum $ unzip- [if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []]- let hasErrors = countErrors /= 0 || (countWarnings /= 0 && not warnings)- test <- pure $- if null test || hasErrors then Nothing- else Just $ intercalate "\n" test-- unless no_title $ setWindowIcon $- if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK-- 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") ++- " " ++ extra ++ [' ' | extra /= ""] ++ "- " ++ project-- updateTitle $ if isJust test then "(running test)" else ""-- -- 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- moduleSorted = sortOn (Down . f) msgError ++ msgWarn- pure $ (if reverse_errors then reverse else id) moduleSorted-- outputFill currTime (Just (loadedCount, 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 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- whenJust test $ \t -> do- whenLoud $ outStrLn $ "%TESTING: " ++ t- sessionExecAsync session t $ \stderr -> do- whenLoud $ outStrLn "%TESTING: Completed"- hFlush stdout -- may not have been a terminating newline from test output- if "*** Exception: " `isPrefixOf` stderr then do- updateTitle "(test failed)"- setWindowIcon IconError- else do- updateTitle "(test done)"- whenNormal $ outStrLn "\n...done"- whenJust lint $ \lintcmd ->- unless hasErrors $ do- (exitcode, stdout, stderr) <- readCreateProcessWithExitCode (shell . unwords $ lintcmd : map escape touched) ""- unless (exitcode == ExitSuccess) $ do- let output = stdout ++ stderr- outStrLn output- forM_ outputfile $ flip writeFile output-- reason <- nextWait $ map (,Restart) restart- ++ map (,Reload) reload- ++ map (,Reload) loaded-- let reason1 = case reason of- Left err ->- (Reload, ["Error when waiting, if this happens repeatedly, raise a ghcid bug.", err])- Right files ->- case partition (\(f, mode) -> mode == Reload) files of- -- Prefer restarts over reloads. E.g., in case of both '--reload=dir'- -- and '--restart=dir', ghcid would restart instead of reload.- (_, rs@(_:_)) -> (Restart, map fst rs)- (rl, _) -> (Reload, map fst rl)-- currTime <- getShortTime- case reason1 of- (Reload, reason2) -> do- unless no_status $ outputFill currTime Nothing evals $ "Reloading..." : map (" " ++) reason2- nextWait <- waitFiles waiter- fire nextWait =<< sessionReload session- (Restart, reason2) -> do- -- exit cleanly, since the whole thing is wrapped in a forever- unless no_status $ outputFill currTime Nothing evals $ "Restarting..." : map (" " ++) reason2- pure Continue-- fire nextWait (messages, loaded, loaded)----- | 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 =- (allGoodMessage ++ " (" ++ show loadedCount ++ " module" ++ ['s' | loadedCount /= 1] ++ ", at " ++ currTime ++ ")")- : concatMap printEval evals-prettyOutput _ _ xs evals = concatMap loadMessage xs ++ concatMap printEval evals--printEval :: EvalResult -> [String]-printEval (EvalResult file (line, col) msg result) =- [ " "- , concat- [ file- , ":"- , show line- , ":"- , show col- ]- ] ++ map ("$> " ++) (lines msg)- ++ lines result---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
@@ -22,8 +22,6 @@ import Control.Applicative import Data.Unique -import System.Console.CmdArgs.Verbosity- import Language.Haskell.Ghcid.Parser import Language.Haskell.Ghcid.Types as T import Language.Haskell.Ghcid.Util@@ -46,10 +44,6 @@ a == b = ghciUnique a == ghciUnique b -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"@@ -62,14 +56,12 @@ 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+ withCreateProcessGroup 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+ let writeInp = hPutStrLn inp -- Some programs (e.g. stack) might use stdin before starting ghci (see #57) -- Send them an empty line@@ -85,13 +77,13 @@ 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 ++ "~#" -- Prepend a leading \n to try and avoid junk already on stdout, -- e.g. https://github.com/ndmitchell/ghcid/issues/291- writeInp $ "\nINTERNAL_GHCID.putStrLn " ++ showStr msg ++ "\n" ++- "INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ showStr msg+ writeInp "\n"+ -- Defining fromString lets us use string literals even when RebindableSyntax is on+ writeInp $ "let fromString s = s in INTERNAL_GHCID.putStrLn " ++ show msg ++ "\n"+ writeInp $ "let fromString s = s in INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ show msg ++ "\n" pure $ isInfixOf msg let syncFresh = do modifyVar_ syncCount $ pure . succ@@ -106,7 +98,6 @@ case el of Left _ -> pure $ Left oldMsg Right l -> do- whenLoud $ outStrLn $ "%" ++ upper (show name) ++ ": " ++ l let msg = removePrefix l res <- finish msg case res of@@ -148,7 +139,7 @@ let ghciInterrupt = withLock isInterrupting $ whenM (fmap isNothing $ withLockTry isRunning $ pure ()) $ do- whenLoud $ outStrLn "%INTERRUPT"+ logDebug "INTERRUPT" interruptProcessGroupOf ghciProcess -- let the person running ghciExec finish, since their sync messages -- may have been the ones that got interrupted@@ -173,7 +164,6 @@ else do -- there may be some initial prompts on stdout before I set the prompt properly s <- pure $ maybe s (removePrefix . snd) $ stripInfix ghcid_prefix s- whenLoud $ outStrLn $ "%STDOUT2: " ++ s modifyIORef (if strm == Stdout then stdout else stderr) (s:) when (any (`isPrefixOf` s) [ "GHCi, version " , "GHCJSi, version "@@ -271,5 +261,5 @@ forkIO $ do -- if nicely doesn't work, kill ghci as the process level sleep 5- terminateProcess $ process ghci+ killProcessGroup $ process ghci quit ghci
src/Language/Haskell/Ghcid/Parser.hs view
@@ -57,6 +57,16 @@ , sev <- if "warning:" `isPrefixOf` lower (unescapeE rest) then Warning else Error = Message sev file pos1 pos2 (map fromEsc $ x:msg) : f las + -- Util.hs: error: [GHC-92213]+ -- Module graph contains a cycle:+ f (x:xs)+ | not $ " " `isPrefixOfE` x+ , Just (file,rest) <- breakFileColon x+ , file /= "<no location info>"+ , "error:" `isPrefixOfE` trimStartE rest+ , (msg,las) <- span leadingWhitespaceE xs+ = Message Error file (0,0) (0,0) (map fromEsc $ x:msg) : f las+ -- <no location info>: can't find file: FILENAME f (x:xs) | Just file <- stripPrefixE "<no location info>: can't find file: " x@@ -71,7 +81,7 @@ -- Module imports form a cycle: -- module `Module' (Module.hs) imports itself f (x:xs)- | unescapeE x == "Module imports form a cycle:"+ | unescapeE x == "Module imports form a cycle:" || unescapeE x == "Module graph contains a cycle:" , (xs,rest) <- span leadingWhitespaceE 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
− src/Language/Haskell/Ghcid/Terminal.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE CPP #-}---- | Cross-platform operations for manipulating terminal console windows.-module Language.Haskell.Ghcid.Terminal(- terminalTopmost,- withWindowIcon, WindowIcon(..), setWindowIcon- ) where--#if defined(mingw32_HOST_OS)-import Data.Word-import Data.Bits-import Control.Exception--import Graphics.Win32.Misc-import Graphics.Win32.Window-import Graphics.Win32.Message-import Graphics.Win32.GDI.Types-import System.Win32.Types---wM_GETICON = 0x007F :: WindowMessage--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "windows.h GetConsoleWindow"- getConsoleWindow :: IO HWND--foreign import CALLCONV unsafe "windows.h SetWindowPos"- setWindowPos :: HWND -> HWND -> Int -> Int -> Int -> Int -> Word32 -> IO Bool-#endif----- | Raise the current terminal on top of all other screens, if you can.-terminalTopmost :: IO ()-#if defined(mingw32_HOST_OS)-terminalTopmost = do- wnd <- getConsoleWindow- setWindowPos wnd hWND_TOPMOST 0 0 0 0 (sWP_NOMOVE .|. sWP_NOSIZE)- pure ()-#else-terminalTopmost = pure ()-#endif---data WindowIcon = IconOK | IconWarning | IconError---- | Change the window icon to green, yellow or red depending on whether the file was errorless, contained only warnings or contained at least one error.-setWindowIcon :: WindowIcon -> IO ()-#if defined(mingw32_HOST_OS)-setWindowIcon x = do- ico <- pure $ case x of- IconOK -> iDI_ASTERISK- IconWarning -> iDI_EXCLAMATION- IconError -> iDI_HAND- icon <- loadIcon Nothing ico- wnd <- getConsoleWindow- -- SMALL is the system tray, BIG is the taskbar and Alt-Tab screen- sendMessage wnd wM_SETICON iCON_SMALL $ fromIntegral $ castPtrToUINTPtr icon- sendMessage wnd wM_SETICON iCON_BIG $ fromIntegral $ castPtrToUINTPtr icon- pure ()-#else-setWindowIcon _ = pure ()-#endif----- | Run an operation in which you call setWindowIcon-withWindowIcon :: IO a -> IO a-#if defined(mingw32_HOST_OS)-withWindowIcon act = do- wnd <- getConsoleWindow- icoBig <- sendMessage wnd wM_GETICON iCON_BIG 0- icoSmall <- sendMessage wnd wM_GETICON iCON_SMALL 0- act `finally` do- sendMessage wnd wM_SETICON iCON_BIG icoBig- sendMessage wnd wM_SETICON iCON_SMALL icoSmall- pure ()-#else-withWindowIcon act = act-#endif
src/Language/Haskell/Ghcid/Util.hs view
@@ -1,16 +1,23 @@+{-# LANGUAGE CPP #-} -- | Utility functions module Language.Haskell.Ghcid.Util( ghciFlagsRequired, ghciFlagsRequiredVersioned,- ghciFlagsUseful, ghciFlagsUsefulVersioned,+ ghciFlagsUseful, dropPrefixRepeatedly, takeRemainder, outStr, outStrLn,+ logErr,+ logInfo,+ logDebug, ignored, allGoodMessage,- getModTime, getModTimeResolution, getShortTime+ getModTime, getModTimeResolution, getShortTime,+ withCreateProcessGroup,+ killProcessGroup ) where +import System.Console.CmdArgs.Verbosity import Control.Concurrent.Extra import System.Time.Extra import System.IO.Unsafe@@ -29,6 +36,11 @@ import Control.Monad.Extra import Control.Applicative import Prelude+import System.Process+#if !defined(mingw32_HOST_OS)+import System.Posix.Process+import System.Posix.Signals+#endif -- | Flags that are required for ghcid to function and are supported on all GHC versions@@ -49,12 +61,7 @@ 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+ ,"-fdiagnostics-color=always" ] @@ -77,6 +84,26 @@ outStrLn :: String -> IO () outStrLn xs = outStr $ xs ++ "\n" +logColor :: Color -> String -> String -> IO ()+logColor color level msg = forM_ (lines msg) $ \line -> outStrLn $+ setSGRCode [SetColor Foreground Dull White]+ ++ "[ghcid] "+ ++ setSGRCode [SetColor Foreground Dull color]+ ++ level+ ++ setSGRCode [SetColor Foreground Dull White]+ ++ " "+ ++ line+ ++ setSGRCode []++logErr :: String -> IO ()+logErr = logColor Red "ERROR"++logInfo :: String -> IO ()+logInfo msg = whenNormal $ logColor Blue " INFO" msg++logDebug :: String -> IO ()+logDebug msg = whenLoud $ logColor Magenta "DEBUG" msg+ -- | Ignore all exceptions coming from an action ignored :: IO () -> IO () ignored act = do@@ -130,3 +157,35 @@ putStrLn $ "Longest file modification time lag was " ++ show (ceiling (mtime * 1000)) ++ "ms" -- add a little bit of safety, but if it's really quick, don't make it that much slower pure $ mtime + min 0.1 mtime++withCreateProcessGroup proc f = do+ let undo (_, _, _, proc) = ignored $ killProcessGroup proc+ bracketOnError (createProcess proc) undo $ \(a,b,c,d) -> f a b c d++-- | Sends SIGKILL to the entire process group.+--+-- This is important when running @cabal repl@, which spawns a child+-- GHCi process.+--+-- @+-- ghcid (process group A)+-- └─ cabal repl (process group B)+-- └─ ghci (process group B)+-- @+--+-- * Bad: send SIGKILL only to @cabal repl@ (leaves @ghci@ running)+-- * Good: send SIGKILL to the whole process group (kills both)+--+-- SIGTERM is not enough, ghci doesn't respect it if it's mid-evaluation.+killProcessGroup :: ProcessHandle -> IO ()+killProcessGroup proc = do+#if defined(mingw32_HOST_OS)+ terminateProcess proc+#else+ pidMaybe <- getPid proc+ case pidMaybe of+ Nothing -> pure ()+ Just pid -> do+ pgid <- getProcessGroupIDOf pid+ signalProcessGroup sigKILL pgid+#endif
− src/Session.hs
@@ -1,258 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | A persistent version of the Ghci session, encoding lots of semantics on top.--- Not suitable for calling multithreaded.-module Session(- Session, enableEval, withSession,- sessionStart, sessionReload,- sessionExecAsync,- ) 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.Console.ANSI-import System.Time.Extra-import System.Process-import System.FilePath-import Control.Exception.Extra-import Control.Concurrent.Extra-import Control.Monad.Extra-import Data.Maybe-import Data.List.Extra-import Control.Applicative-import Prelude-import System.IO.Extra---data Session = Session- {ghci :: IORef (Maybe Ghci) -- ^ The Ghci session, or Nothing if there is none- ,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- ,allowEval :: Bool -- ^ Is the allow-eval flag set?- }--enableEval :: Session -> Session-enableEval s = s { allowEval = True }---debugShutdown x = when False $ print ("DEBUG SHUTDOWN", x)---- | The function 'withSession' expects to be run on the main thread,--- but the inner function will not. This ensures Ctrl-C is handled--- properly and any spawned Ghci processes will be aborted.-withSession :: (Session -> IO a) -> IO a-withSession f = do- ghci <- newIORef Nothing- command <- newIORef Nothing- warnings <- newIORef []- curdir <- newIORef "."- running <- newVar False- debugShutdown "Starting session"- withThread <- myThreadId- let allowEval = False- f Session{..} `finally` do- debugShutdown "Start finally"- modifyVar_ running $ const $ pure False- whenJustM (readIORef ghci) $ \v -> do- writeIORef ghci Nothing- debugShutdown "Calling kill"- kill v- debugShutdown "Finish finally"----- | Kill. Wait just long enough to ensure you've done the job, but not to see the results.-kill :: Ghci -> IO ()-kill ghci = ignored $ do- timeout 5 $ do- debugShutdown "Before quit"- ignored $ quit ghci- debugShutdown "After quit"- debugShutdown "Before terminateProcess"- ignored $ terminateProcess $ process ghci- debugShutdown "After terminateProcess"- -- Ctrl-C after a tests keeps the cursor hidden,- -- `setSGR []`didn't seem to be enough- -- See: https://github.com/ndmitchell/ghcid/issues/254- showCursor--loadedModules :: FilePath -> [Load] -> [FilePath]-loadedModules dir = nubOrd . map (loadFile . qualify dir) . filter predicate- where- predicate Message{loadFile = loadFile} = loadFile /= "<unknown>"- predicate Loading{loadFile = loadFile} = loadFile /= "<unknown>"- predicate _ = False--qualify :: FilePath -> Load -> Load-qualify dir message = message{loadFile = dir </> loadFile message}---- | 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 -> [String] -> IO ([Load], [FilePath])-sessionStart Session{..} cmd setup = do- modifyVar_ running $ const $ pure False- writeIORef command $ Just (cmd, setup)-- -- cleanup any old instances- whenJustM (readIORef ghci) $ \v -> do- writeIORef ghci Nothing- void $ forkIO $ kill v-- -- start the new- outStrLn $ "Loading " ++ cmd ++ " ..."- (v, messages) <- mask $ \unmask -> do- (v, messages) <- unmask $ startGhci cmd Nothing $ const outStrLn- writeIORef ghci $ Just v- pure (v, messages)-- -- do whatever preparation was requested- exec v $ unlines setup-- -- deal with current directory- (dir, _) <- showPaths v- writeIORef curdir dir- messages <- pure $ map (qualify dir) messages-- let loaded = loadedModules dir messages- evals <- performEvals v allowEval loaded-- -- install a handler- forkIO $ do- code <- waitForProcess $ process v- whenJustM (readIORef ghci) $ \ghci ->- when (ghci == v) $ do- sleep 0.3 -- give anyone reading from the stream a chance to throw first- throwTo withThread $ ErrorCall $ "Command \"" ++ cmd ++ "\" exited unexpectedly with " ++ show code-- -- handle what the process returned- messages <- pure $ mapMaybe tidyMessage messages- writeIORef warnings $ getWarnings messages- pure (messages ++ evals, loaded)---getWarnings :: [Load] -> [Load]-getWarnings messages = [m | m@Message{..} <- messages, loadSeverity == Warning]----- | Call 'sessionStart' at the previous command.-sessionRestart :: Session -> IO ([Load], [FilePath])-sessionRestart session@Session{..} = do- Just (cmd, setup) <- readIORef command- sessionStart session cmd setup---performEvals :: Ghci -> Bool -> [FilePath] -> IO [Load]-performEvals _ False _ = pure []-performEvals ghci True reloaded = do- cmds <- mapM getCommands reloaded- fmap join $ forM cmds $ \(file, cmds') ->- forM cmds' $ \(num, cmd) -> do- ref <- newIORef []- execStream ghci cmd $ \_ resp -> modifyIORef ref (resp :)- resp <- unlines . reverse <$> readIORef ref- pure $ Eval $ EvalResult file (num, 1) cmd resp---getCommands :: FilePath -> IO (FilePath, [(Int, String)])-getCommands fp = do- ls <- readFileUTF8' fp- pure (fp, splitCommands $ zipFrom 1 $ lines ls)--splitCommands :: [(Int, String)] -> [(Int, String)]-splitCommands [] = []-splitCommands ((num, line) : ls)- | isCommand line =- let (cmds, xs) = span (isCommand . snd) ls- in (num, unwords $ fmap (drop $ length commandPrefix) $ line : fmap snd cmds) : splitCommands xs- | isMultilineCommandPrefix line =- let (cmds, xs) = break (isMultilineCommandSuffix . snd) ls- in (num, unlines (wrapGhciMultiline (fmap snd cmds))) : splitCommands (drop1 xs)- | otherwise = splitCommands ls--isCommand :: String -> Bool-isCommand = isPrefixOf commandPrefix--commandPrefix :: String-commandPrefix = "-- $> "--isMultilineCommandPrefix :: String -> Bool-isMultilineCommandPrefix = (==) multilineCommandPrefix--multilineCommandPrefix :: String-multilineCommandPrefix = "{- $>"--isMultilineCommandSuffix :: String -> Bool-isMultilineCommandSuffix = (==) multilineCommandSuffix--multilineCommandSuffix :: String-multilineCommandSuffix = "<$ -}"--wrapGhciMultiline :: [String] -> [String]-wrapGhciMultiline xs = [":{"] ++ xs ++ [":}"]---- | Reload, returning the same information as 'sessionStart'. In particular, any--- information that GHCi doesn't repeat (warnings from loaded modules) will be--- added back in.-sessionReload :: Session -> IO ([Load], [FilePath], [FilePath])-sessionReload session@Session{..} = do- -- kill anything async, set stuck if you didn't succeed- old <- modifyVar running $ \b -> pure (False, b)- stuck <- if not old then pure False else do- Just ghci <- readIORef ghci- fmap isNothing $ timeout 5 $ interrupt ghci-- if stuck- then (\(messages,loaded) -> (messages,loaded,loaded)) <$> sessionRestart session- else do- -- actually reload- Just ghci <- readIORef ghci- dir <- readIORef curdir- messages <- mapMaybe tidyMessage <$> reload ghci- loaded <- map ((dir </>) . snd) <$> showModules ghci- let reloaded = loadedModules dir messages- warn <- readIORef warnings- evals <- performEvals ghci allowEval reloaded-- -- only keep old warnings from files that are still loaded, but did not reload- let validWarn w = loadFile w `elem` loaded && loadFile w `notElem` reloaded- -- newest warnings always go first, so the file you hit save on most recently has warnings first- messages <- pure $ messages ++ filter validWarn warn-- writeIORef warnings $ getWarnings messages- pure (messages ++ evals, nubOrd (loaded ++ reloaded), reloaded)----- | Run an exec operation asynchronously. Should not be a @:reload@ or similar.--- Will be automatically aborted if it takes too long. Only fires done if not aborted.--- Argument to done is the final stderr line.-sessionExecAsync :: Session -> String -> (String -> IO ()) -> IO ()-sessionExecAsync Session{..} cmd done = do- Just ghci <- readIORef ghci- stderr <- newIORef ""- modifyVar_ running $ const $ pure True- caller <- myThreadId- void $ flip forkFinally (either (throwTo caller) (const $ pure ())) $ do- execStream ghci cmd $ \strm msg ->- when (msg /= "*** Exception: ExitSuccess") $ do- when (strm == Stderr) $ writeIORef stderr msg- outStrLn msg- old <- modifyVar running $ \b -> pure (False, b)- -- don't fire Done if someone interrupted us- stderr <- readIORef stderr- when old $ done stderr----- | Ignore entirely pointless messages and remove unnecessary lines.-tidyMessage :: Load -> Maybe Load-tidyMessage Message{loadSeverity=Warning, loadMessage=[_,x]}- | unescape x == " -O conflicts with --interactive; -O ignored." = Nothing-tidyMessage m@Message{..}- = 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.hs
@@ -1,25 +0,0 @@--module Test(main) where--import Test.Tasty-import System.IO-import System.Console.CmdArgs--import Test.Util-import Test.Parser-import Test.API-import Test.Ghcid--main :: IO ()-main = do- hSetBuffering stdout NoBuffering- setVerbosity Loud- defaultMain tests--tests :: TestTree-tests = testGroup "Tests" $ take 3 -- TEMPORARY- [utilsTests- ,parserTests- ,apiTests- ,ghcidTest- ]
− src/Test/API.hs
@@ -1,37 +0,0 @@--- | Test the high level library API-module Test.API(apiTests) where--import Test.Tasty-import Test.Tasty.HUnit-import System.FilePath-import System.IO.Extra-import System.Time.Extra-import Language.Haskell.Ghcid-import Language.Haskell.Ghcid.Util-import Test.Common---apiTests :: TestTree-apiTests = testGroup "API test"- [testCase "No files" $ withTempDir $ \dir -> do- (ghci,load) <- startGhci "ghci -ignore-dot-ghci" (Just dir) $ const putStrLn- load @?= []- showModules ghci >>= (@?= [])- exec ghci "import Data.List"- exec ghci "nub \"test\"" >>= (@?= ["\"tes\""])- stopGhci ghci-- ,disable19650 $ testCase "Load file" $ withTempDir $ \dir -> do- writeFile (dir </> "File.hs") "module A where\na = 123"- (ghci, load) <- startGhci "ghci -ignore-dot-ghci File.hs" (Just dir) $ const putStrLn- load @?= [Loading "A" "File.hs"]- exec ghci "a + 1" >>= (@?= ["124"])- reload ghci >>= (@?= [])-- sleep =<< getModTimeResolution- writeFile (dir </> "File.hs") "module A where\na = 456"- exec ghci "a + 1" >>= (@?= ["124"])- reload ghci >>= (@?= [Loading "A" "File.hs"])- exec ghci "a + 1" >>= (@?= ["457"])- stopGhci ghci- ]
− src/Test/Common.hs
@@ -1,13 +0,0 @@--module Test.Common(disable19650) where--import Test.Tasty-import System.Info-import Data.Version---- Tests which are disabled due to https://gitlab.haskell.org/ghc/ghc/-/issues/19650--- readily resetting which packages are loaded-disable19650 :: TestTree -> TestTree-disable19650 x- | compilerVersion < makeVersion [9] = x- | otherwise = testGroup "Disabled" []
− src/Test/Ghcid.hs
@@ -1,241 +0,0 @@---- | Test behavior of the executable, polling files for changes-module Test.Ghcid(ghcidTest) where--import Control.Concurrent.Extra-import Control.Exception.Extra-import Control.Monad.Extra-import Data.Char-import Data.List.Extra-import System.Directory.Extra-import System.IO.Extra-import System.Time.Extra-import Data.Version.Extra-import System.Environment-import System.Process.Extra-import System.FilePath-import System.Exit--import Test.Tasty-import Test.Tasty.HUnit--import Ghcid-import Language.Haskell.Ghcid.Escape-import Language.Haskell.Ghcid.Util-import Test.Common-import Data.Functor-import Prelude---ghcidTest :: TestTree-ghcidTest = testGroup "Ghcid test"- [basicTest- ,cdTest- ,dotGhciTest- ,cabalTest- ,stackTest- ]---freshDir :: IO a -> IO a-freshDir act = withTempDir $ \tdir -> withCurrentDirectory tdir act--copyDir :: FilePath -> IO a -> IO ()-copyDir dir act = do- b <- doesDirectoryExist dir- if not b then putStrLn $ "Couldn't run test because test source is missing, " ++ dir else void $- withTempDir $ \tdir -> do- xs <- withCurrentDirectory dir $ listFilesRecursive "."- forM_ xs $ \x -> do- createDirectoryIfMissing True $ takeDirectory $ tdir </> x- copyFile (dir </> x) (tdir </> x)- withCurrentDirectory tdir act---whenExecutable :: String -> IO a -> IO ()-whenExecutable exe act = do- v <- findExecutable exe- case v of- Nothing -> putStrLn $ "Couldn't run test because " ++ exe ++ " is missing"- Just _ -> void act---withGhcid :: [String] -> (([String] -> IO ()) -> IO a) -> IO a-withGhcid args script = do- chan <- newChan- let require want = do- t <- timeout 30 $ readChan chan- case t of- Nothing -> fail $ "Require failed to produce results in time, expected: " ++ show want- Just got -> assertApproxInfix want got- sleep =<< getModTimeResolution-- 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 ()) $- withArgs (["--no-title","--no-status"]++args) $- mainWithTerminal (pure $ TermSize 100 (Just 50) WrapHard) output)- killThread $ \_ -> script require- waitBarrier done- pure res----- | Since different versions of GHCi give different messages, we only try to find what--- we require anywhere in the obtained messages, ignoring weird characters.-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 == ':') . unescape- got2 = simple $ unwords got- all ((`isInfixOf` got2) . simple) want @?- "Expected " ++ show want ++ ", got " ++ show got---write :: FilePath -> String -> IO ()-write file x = do- print ("writeFile",file,x)- createDirectoryIfMissing True $ takeDirectory file- writeFile file x--append :: FilePath -> String -> IO ()-append file x = do- print ("appendFile",file,x)- appendFile file x--rename :: FilePath -> FilePath -> IO ()-rename from to = do- print ("renameFile",from,to)- renameFile from to---------------------------------------------------------------------------- ACTUAL TEST SUITE--basicTest :: TestTree-basicTest = disable19650 $ testCase "Ghcid basic" $ freshDir $ do- write "Main.hs" "main = print 1"- withGhcid ["-cghci -fwarn-unused-binds Main.hs"] $ \require -> do- require [allGoodMessage]- write "Main.hs" "x"- require ["Main.hs:1:1"," Parse error:"]-- -- Github issue 275- write "Main.hs" "{-# LINE 42 \"foo.bar\" #-}\nx"- require ["foo.bar:42:1", "Parse error:"]-- write "Util.hs" "module Util where"- write "Main.hs" "import Util\nmain = print 1"- require [allGoodMessage]- write "Util.hs" "module Util where\nx"- require ["Util.hs:2:1","Parse error:"]- write "Util.hs" "module Util() where\nx = 1"- require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]-- -- check warnings persist properly- write "Main.hs" "import Util\nx"- require ["Main.hs:2:1","Parse error:"- ,"Util.hs:2:1","Warning:","Defined but not used: `x'"]- write "Main.hs" "import Util\nmain = print 2"- require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]- write "Main.hs" "main = print 3"- require [allGoodMessage]- write "Main.hs" "import Util\nmain = print 4"- require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]- write "Util.hs" "module Util where"- require [allGoodMessage]-- -- check recursive modules work- write "Util.hs" "module Util where\nimport Main"- require ["imports form a cycle","Main.hs","Util.hs"]- write "Util.hs" "module Util where"- require [allGoodMessage]-- ghcVer <- readVersion <$> systemOutput_ "ghc --numeric-version"-- -- check renaming files works- when (ghcVer < makeVersion [8]) $ do- -- 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'"]- rename "Util2.hs" "Util.hs"- require [allGoodMessage]-- -- after this point GHC bugs mean nothing really works too much---cdTest :: TestTree-cdTest = disable19650 $ 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" ""- ignore $ void $ system "chmod go-w .ghci"- withGhcid ["--test=:test"] $ \require -> do- require [allGoodMessage]- sleep 1 -- time to write out the test- readFile "test.txt" >>= (@?= "X") -- the test writes out X- append "Test.hs" "\n"- require [allGoodMessage]- sleep 1 -- time to write out the test- readFile "test.txt" >>= (@?= "XX")- print =<< readFile ".ghci"- write ".ghci" ":set -fwarn-unused-imports\n:load Root Paths.hs Test"- require ["The import of Paths_foo is redundant"]- sleep 1 -- time to write out the test- readFile "test.txt" >>= (@?= "XX") -- but shouldn't run on warning---cabalTest :: TestTree-cabalTest = testCase "Ghcid Cabal" $ copyDir "test/bar" $ whenExecutable "cabal" $ do- env <- getEnvironment- let db = ["--package-db=" ++ x | x <- maybe [] splitSearchPath $ lookup "GHC_PACKAGE_PATH" env]- (_, _, _, pid) <- createProcess $- (proc "cabal" $ "configure":db){env = Just $ filter ((/=) "GHC_PACKAGE_PATH" . fst) env}- ExitSuccess <- waitForProcess pid-- withGhcid [] $ \require -> do- require [allGoodMessage]- orig <- readFile' "src/Literate.lhs"- append "src/Literate.lhs" "> x"- require ["src/Literate.lhs:5:3","Parse error:"]- write "src/Literate.lhs" orig- require [allGoodMessage]--stackTest :: TestTree-stackTest = testCase "Ghcid Stack" $ copyDir "test/bar" $ whenExecutable "stack" $ do- 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 ++ " (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:"]-{-- -- Stack seems to have changed, and continues to do so - lets just test the basics- withGhcid ["src/Boot.hs"] $ \require -> do- require [allGoodMessage]- writeFile "src/Boot.hs" "X"- require ["src/Boot.hs:1:1","Parse error:"]--}
− src/Test/Parser.hs
@@ -1,213 +0,0 @@--- | Test the message parser-module Test.Parser(parserTests) where--import Test.Tasty-import Test.Tasty.HUnit--import Language.Haskell.Ghcid.Parser-import Language.Haskell.Ghcid.Types---parserTests :: TestTree-parserTests = testGroup "Parser tests"- [testParseShowModules- ,testParseShowPaths- ,testParseLoad- ,testParseLoadGhc82- ,testParseLoadSpans- ,testParseLoadCycles- ,testParseLoadCyclesSelf- ,testParseLoadEscapeCodes- ,testMissingFile- ]--testParseShowModules :: TestTree-testParseShowModules = testCase "Show Modules" $ parseShowModules- ["Main ( src/Main.hs, interpreted )"- ,"AI.Neural.WiscDigit ( src/AI/Neural/WiscDigit.hs, interpreted )"- ] @?=- [("Main","src/Main.hs")- ,("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 )"- ,"GHCi.hs:70:1: Parse error: naked expression at top level"- ,"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"- ,"GHCi.hs:81:1: Warning: Defined but not used: `foo'"- ,"C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase- ,"src\\Haskell.hs:4:23:"- ," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"- ,"src\\Boot.hs-boot:2:8:"- ," File name does not match module name:"- ," Saw: `BootX'"- ," Expected: `Boot'"- ] @?=- [Loading "GHCi" "GHCi.hs"- ,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-testParseLoadGhc82 = testCase "GHC 8.2 Load Parsing" $ parseLoad- ["[18 of 24] Compiling Physics ( Physics.hs, interpreted )"- ,"Physics.hs:30:18: error: parse error on input ‘^*’"- ," |"- ,"30 | dx = ' ^* delta"- ," | ^^"- ,"Loaded GHCi configuration from C:\\Neil\\ghcid\\.ghci"- ] @?=- [Loading "Physics" "Physics.hs"- ,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"- ]--testMissingFile = testCase "Starting ghci with a non-existent filename" $ parseLoad- ["<no location info>: error: can't find file: bob.hs"- ] @?=- [Message Error "<unknown>" (0,0) (0,0) ["<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 )"- ,"GHCi.hs:70:1-2: Parse error: naked expression at top level"- ,"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"- ,"GHCi.hs:81:1-15: Warning: Defined but not used: `foo'"- ,"C:\\GHCi.hs:82:1-17: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase- ,"src\\Haskell.hs:4:23-24:"- ," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"- ,"src\\Boot.hs-boot:2:8-5:"- ," File name does not match module name:"- ," Saw: `BootX'"- ," Expected: `Boot'"- ,"/src/TrieSpec.hs:(192,7)-(193,76): Warning:"- ," A do-notation statement discarded a result of type ‘[()]’"- ] @?=- [Loading "GHCi" "GHCi.hs"- ,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
@@ -1,31 +0,0 @@---- | Test utility functions-module Test.Util(utilsTests) where--import Test.Tasty-import Test.Tasty.HUnit--import Language.Haskell.Ghcid.Util-import Language.Haskell.Ghcid.Escape--utilsTests :: TestTree-utilsTests = testGroup "Utility tests"- [dropPrefixTests- ,wordWrapTests- ]--dropPrefixTests :: TestTree-dropPrefixTests = testGroup "dropPrefix"- [testCase "Prefix not found" $ dropPrefixRepeatedly "prefix" "string" @?= "string"- ,testCase "Empty prefix" $ dropPrefixRepeatedly "" "string" @?= "string"- ,testCase "Prefix found once" $ dropPrefixRepeatedly "str" "string" @?= "ing"- ,testCase "Prefix found twice" $ dropPrefixRepeatedly "str" "strstring" @?= "ing"- ]--wordWrapTests :: TestTree-wordWrapTests = testGroup "wordWrap"- [testCase "Max 0" $ wordWrapE 4 0 (Esc "ab cd efgh") @?= [s"ab c",s"d ef",h"gh"]- ,testCase "Max 2" $ wordWrapE 4 2 (Esc "ab cd efgh") @?= [h"ab ",h"cd ",h"efgh"]- ]- where h x = (Esc x, WrapHard)- s x = (Esc x, WrapSoft)
− src/Wait.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}---- | Use 'withWaiterPoll' or 'withWaiterNotify' to create a 'Waiter' object,--- then access it (single-threaded) by using 'waitFiles'.-module Wait(Waiter, withWaiterPoll, withWaiterNotify, waitFiles) where--import Control.Concurrent.Extra-import qualified Data.Map as Map-import qualified Data.Set as Set-import Control.Monad.Extra-import Data.List.Extra-import System.FilePath-import Control.Exception.Extra-import System.Directory.Extra-import Data.Time.Clock-import Data.String-import System.Console.CmdArgs-import System.Time.Extra-import System.FSNotify-import Language.Haskell.Ghcid.Util---data Waiter- = WaiterPoll Seconds- | WaiterNotify WatchManager (MVar ()) (Var (Map.Map FilePath StopListening))--withWaiterPoll :: Seconds -> (Waiter -> IO a) -> IO a-withWaiterPoll x f = f $ WaiterPoll x--withWaiterNotify :: (Waiter -> IO a) -> IO a-withWaiterNotify f = withManagerConf defaultConfig $ \manager -> do- mvar <- newEmptyMVar- var <- newVar Map.empty- f $ WaiterNotify manager mvar var---- `listContentsInside test dir` will list files and directories inside `dir`,--- recursing into those subdirectories which pass `test`.--- Note that `dir` and files it directly contains are always listed, regardless of `test`.--- Subdirectories will have a trailing path separator, and are only listed if we recurse into them.-listContentsInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]-listContentsInside test dir = do- (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir- recurse <- filterM test dirs- rest <- concatMapM (listContentsInside test) recurse- pure $ addTrailingPathSeparator dir : files ++ rest---- | Given the pattern:------ > wait <- waitFiles waiter--- > ...--- > wait ["File1.hs","File2.hs"]------ This continues as soon as either @File1.hs@ or @File2.hs@ changes,--- starting from when 'waitFiles' was initially called.------ returns a message about why you are continuing (usually a file name).-waitFiles :: forall a. Ord a => Waiter -> IO ([(FilePath, a)] -> IO (Either String [(FilePath, a)]))-waitFiles waiter = do- base <- getCurrentTime- pure $ \files -> handle onError (go base files)- where- onError :: IOError -> IO (Either String [(FilePath, a)])- onError e = sleep 1.0 >> pure (Left (show e))-- go :: UTCTime -> [(FilePath, a)] -> IO (Either String [(FilePath, a)])- go base files = do- whenLoud $ outStrLn $ "%WAITING: " ++ unwords (map fst files)- -- As listContentsInside returns directories, we are waiting on them explicitly and so- -- will pick up new files, as creating a new file changes the containing directory's modtime.- files <- concatForM files $ \(file, a) ->- ifM (doesDirectoryExist file) (fmap (,a) <$> listContentsInside (pure . not . isPrefixOf "." . takeFileName) file) (pure [(file, a)])- case waiter of- WaiterPoll t -> pure ()- WaiterNotify manager kick mp -> do- dirs <- fmap Set.fromList $ mapM canonicalizePathSafe $ nubOrd $ map (takeDirectory . fst) files- modifyVar_ mp $ \mp -> do- let (keep,del) = Map.partitionWithKey (\k v -> k `Set.member` dirs) mp- sequence_ $ Map.elems del- new <- forM (Set.toList $ dirs `Set.difference` Map.keysSet keep) $ \dir -> do- can <- watchDir manager (fromString dir) (const True) $ \event -> do- whenLoud $ outStrLn $ "%NOTIFY: " ++ show event- void $ tryPutMVar kick ()- pure (dir, can)- let mp2 = keep `Map.union` Map.fromList new- whenLoud $ outStrLn $ "%WAITING: " ++ unwords (Map.keys mp2)- pure mp2- void $ tryTakeMVar kick- new <- mapM (getModTime . fst) files- case [x | (x,Just t) <- zip files new, t > base] of- [] -> Right <$> recheck files new- xs -> pure (Right xs)-- recheck :: [(FilePath, a)] -> [Maybe UTCTime] -> IO [(String, a)]- recheck files old = do- sleep 0.1- case waiter of- WaiterPoll t -> sleep $ max 0 $ t - 0.1 -- subtract the initial 0.1 sleep from above- WaiterNotify _ kick _ -> do- takeMVar kick- whenLoud $ outStrLn "%WAITING: Notify signaled"- new <- mapM (getModTime . fst) files- case [x | (x,t1,t2) <- zip3 files old new, t1 /= t2] of- [] -> recheck files new- xs -> do- let disappeared = [x | (x, Just _, Nothing) <- zip3 files old new]- unless (null disappeared) $ do- -- if someone is deleting a needed file, give them some space to put the file back- -- typically caused by VIM- -- but try not to- whenLoud $ outStrLn $ "%WAITING: Waiting max of 1s due to file removal, " ++ unwords (nubOrd (map fst disappeared))- -- at most 20 iterations, but stop as soon as the file returns- void $ flip firstJustM (replicate 20 ()) $ \_ -> do- sleep 0.05- new <- mapM (getModTime . fst) files- pure $ if null [x | (x, Just _, Nothing) <- zip3 files old new] then Just () else Nothing- pure xs---canonicalizePathSafe :: FilePath -> IO FilePath-canonicalizePathSafe x = canonicalizePath x `catch` \(_ :: IOError) -> pure x
+ test/Test.hs view
@@ -0,0 +1,26 @@++module Test(main) where++import Test.Tasty+import Test.Tasty.Runners (NumThreads(..))+import System.IO++import Test.Util+import Test.Parser+import Test.API+import Test.Ghcid++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ defaultMain tests++tests :: TestTree+-- Several integration tests temporarily change the process-wide current+-- directory, so they must not overlap with each other.+tests = localOption (NumThreads 1) $ testGroup "Tests"+ [utilsTests+ ,parserTests+ ,apiTests+ ,ghcidTest+ ]
+ test/Test/API.hs view
@@ -0,0 +1,61 @@+-- | Test the high level library API+module Test.API(apiTests) where++import Test.Tasty+import Test.Tasty.HUnit+import System.FilePath+import System.IO.Extra+import System.Time.Extra+import Language.Haskell.Ghcid+import Language.Haskell.Ghcid.Util+import Test.Common+import Test.Util+++apiTests :: TestTree+apiTests = localOption (mkTimeout 30000000) $ testGroup "API test"+ [testCase "No files" $ withTempDir $ \dir -> do+ echo <- testEcho+ (ghci,load) <- startGhci "ghci -ignore-dot-ghci" (Just dir) echo+ load @?= []+ showModules ghci >>= (@?= [])+ exec ghci "import Data.List"+ exec ghci "nub \"test\"" >>= (@?= ["\"tes\""])+ stopGhci ghci++ ,disable19650 $ testCase "Load file" $ withTempDir $ \dir -> do+ writeFile (dir </> "File.hs") "module A where\na = 123"+ echo <- testEcho+ (ghci, load) <- startGhci "ghci -ignore-dot-ghci File.hs" (Just dir) echo+ load @?= [Loading "A" "File.hs"]+ exec ghci "a + 1" >>= (@?= ["124"])+ reload ghci >>= (@?= [])++ sleep =<< getModTimeResolution+ writeFile (dir </> "File.hs") "module A where\na = 456"+ exec ghci "a + 1" >>= (@?= ["124"])+ reload ghci >>= (@?= [Loading "A" "File.hs"])+ exec ghci "a + 1" >>= (@?= ["457"])+ stopGhci ghci++ -- ,testCase "Rewrite IDE paths" $ do+ -- let projectDir = "/project"+ -- rewriteRequestForGhci PathRelative projectDir ":type-at /project/app/Main.hs 5 34 5 38"+ -- @?= ":type-at app/Main.hs 5 34 5 38"+ -- rewriteRequestForGhci PathRelative projectDir ":type-at /other/Main.hs 5 34 5 38"+ -- @?= ":type-at /other/Main.hs 5 34 5 38"+ -- rewriteRequestForGhci PathRelative projectDir ":uses /project/dir with spaces/Main.hs 1 1 1 4"+ -- @?= ":uses dir with spaces/Main.hs 1 1 1 4"+ -- rewriteRequestForGhci PathAbsolute projectDir ":type-at /project/app/Main.hs 5 34 5 38"+ -- @?= ":type-at /project/app/Main.hs 5 34 5 38"+ -- rewriteResponseFromGhci PathRelative projectDir ["app/Main.hs:(5,34)-(5,38)", "app/Main.hs:5:34-38", "plain text"]+ -- @?= ["/project/app/Main.hs:(5,34)-(5,38)", "/project/app/Main.hs:5:34-38", "plain text"]+ -- rewriteResponseFromGhci PathAbsolute projectDir ["app/Main.hs:(5,34)-(5,38)"]+ -- @?= ["app/Main.hs:(5,34)-(5,38)"]+ ]+++testEcho :: IO (Stream -> String -> IO ())+testEcho = do+ verbose <- isVerbose+ pure $ if verbose then const putStrLn else \_ _ -> pure ()
+ test/Test/Common.hs view
@@ -0,0 +1,13 @@++module Test.Common(disable19650) where++import Test.Tasty+import System.Info+import Data.Version++-- Tests which are disabled due to https://gitlab.haskell.org/ghc/ghc/-/issues/19650+-- readily resetting which packages are loaded+disable19650 :: TestTree -> TestTree+disable19650 x+ | compilerVersion >= makeVersion [9,0] && compilerVersion < makeVersion [9,2] = testGroup "Disabled" []+ | otherwise = x
+ test/Test/Ghcid.hs view
@@ -0,0 +1,222 @@++-- | Test behavior of the executable, polling files for changes+module Test.Ghcid(ghcidTest) where++import Control.Concurrent.Extra+import Control.Exception.Extra+import Control.Monad.Extra+import Data.Char+import Data.List.Extra+import Data.Maybe+import System.Directory.Extra+import System.IO.Extra+import System.Time.Extra+import Data.Version.Extra+import System.Environment+import System.Process.Extra+import System.FilePath+import System.Exit++import Test.Tasty+import Test.Tasty.HUnit++import Ghcid (TermSize(..), mainWithTerminal, shouldWatchLoadConfig)+import Language.Haskell.Ghcid.Escape+import Language.Haskell.Ghcid.Util+import Test.Common+import Test.Util+import Data.Functor+import Prelude+++ghcidTest :: TestTree+ghcidTest = localOption (mkTimeout 30000000) $ testGroup "Ghcid test"+ [basicTest+ ,cdTest+ ,dotGhciTest+ ,loadConfigRestartFilterTest+ ,cabalTest+ ]+++freshDir :: IO a -> IO a+freshDir act = withTempDir $ \tdir -> withCurrentDirectory tdir act++copyDir :: FilePath -> IO a -> IO ()+copyDir dir act = do+ b <- doesDirectoryExist dir+ if not b then putStrLn $ "Couldn't run test because test source is missing, " ++ dir else void $+ withTempDir $ \tdir -> do+ xs <- withCurrentDirectory dir $ listFilesRecursive "."+ forM_ xs $ \x -> do+ createDirectoryIfMissing True $ takeDirectory $ tdir </> x+ copyFile (dir </> x) (tdir </> x)+ withCurrentDirectory tdir act+++whenExecutable :: String -> IO a -> IO ()+whenExecutable exe act = do+ v <- findExecutable exe+ case v of+ Nothing -> putStrLn $ "Couldn't run test because " ++ exe ++ " is missing"+ Just _ -> void act+++withGhcid :: [String] -> (([String] -> IO ()) -> IO a) -> IO a+withGhcid args script = do+ chan <- newChan+ verbose <- isJust <$> lookupEnv "GHCID_TEST_VERBOSE"+ let require want = do+ t <- timeout 30 $ readChan chan+ case t of+ Nothing -> fail $ "Require failed to produce results in time, expected: " ++ show want+ Just got -> assertApproxInfix want got+ -- Ensure the next write gets a distinguishable modification time. Sleeping+ -- for exactly the measured resolution can still leave both writes in the+ -- same timestamp bucket when the sleep straddles its boundary imprecisely.+ resolution <- getModTimeResolution+ sleep $ max 0.05 $ resolution * 2++ let output msg = do+ let msg2 = filter (/= "") msg+ when verbose $+ putStr $ unlines $ map ("%PRINT: "++) msg2+ writeChan chan msg2+ done <- newBarrier+ res <- bracket+ (flip forkFinally (const $ signalBarrier done ()) $+ withArgs (["--quiet","--no-title","--no-status"]++args) $+ mainWithTerminal (pure $ TermSize 100 (Just 50) WrapHard) output)+ killThread $ \_ -> script require+ waitBarrier done+ pure res+++-- | Since different versions of GHCi give different messages, we only try to find what+-- we require anywhere in the obtained messages, ignoring weird characters.+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 == ':') . unescape+ got2 = simple $ unwords got+ all ((`isInfixOf` got2) . simple) want @?+ "Expected " ++ show want ++ ", got " ++ show got++write :: FilePath -> String -> IO ()+write file x = do+ whenVerbose $ print ("writeFile",file,x)+ createDirectoryIfMissing True $ takeDirectory file+ writeFile file x++append :: FilePath -> String -> IO ()+append file x = do+ whenVerbose $ print ("appendFile",file,x)+ appendFile file x++rename :: FilePath -> FilePath -> IO ()+rename from to = do+ whenVerbose $ print ("renameFile",from,to)+ renameFile from to++++---------------------------------------------------------------------+-- ACTUAL TEST SUITE++basicTest :: TestTree+basicTest = disable19650 $ testCase "Ghcid basic" $ freshDir $ do+ write "Main.hs" "main = print 1"+ withGhcid ["-cghci -fwarn-unused-binds Main.hs"] $ \require -> do+ require [allGoodMessage]+ write "Main.hs" "x"+ require ["Main.hs:1:1"," Parse error:"]++ -- Github issue 275+ write "Main.hs" "{-# LINE 42 \"foo.bar\" #-}\nx"+ require ["foo.bar:42:1", "Parse error:"]++ write "Util.hs" "module Util where"+ write "Main.hs" "import Util\nmain = print 1"+ require [allGoodMessage]+ write "Util.hs" "module Util where\nx"+ require ["Util.hs:2:1","Parse error:"]+ write "Util.hs" "module Util() where\nx = 1"+ require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]++ -- check recursive modules work+ write "Util.hs" "module Util where\nimport Main"+ require ["cycle","Main.hs","Util.hs"]+ write "Util.hs" "module Util where"+ require [allGoodMessage]++ ghcVer <- readVersion <$> systemOutput_ "ghc --numeric-version"++ -- check renaming files works+ when (ghcVer < makeVersion [8]) $ do+ -- 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'"]+ rename "Util2.hs" "Util.hs"+ require [allGoodMessage]++ -- after this point GHC bugs mean nothing really works too much+++cdTest :: TestTree+cdTest = disable19650 $ 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" ""+ ignore $ void $ system "chmod go-w .ghci"+ withGhcid ["--test=:test"] $ \require -> do+ require [allGoodMessage]+ sleep 1 -- time to write out the test+ readFile "test.txt" >>= (@?= "X") -- the test writes out X+ append "Test.hs" "\n"+ require [allGoodMessage]+ sleep 1 -- time to write out the test+ readFile "test.txt" >>= (@?= "XX")+ print =<< readFile ".ghci"+ write ".ghci" ":set -fwarn-unused-imports\n:load Root Paths.hs Test"+ require ["The import of Paths_foo is redundant"]+ sleep 1 -- time to write out the test+ readFile "test.txt" >>= (@?= "XX") -- but shouldn't run on warning+++loadConfigRestartFilterTest :: TestTree+loadConfigRestartFilterTest = testCase "Ignore generated cabal script setcwd.ghci" $ do+ shouldWatchLoadConfig "/Users/test/.cabal/script-builds/hash/setcwd.ghci" @?= False+ shouldWatchLoadConfig "/Users/test/project/.ghci" @?= True+ shouldWatchLoadConfig "foo/.ghci" @?= True+++cabalTest :: TestTree+cabalTest = testCase "Ghcid Cabal" $ copyDir "test/bar" $ whenExecutable "cabal" $ do+ env <- getEnvironment+ let db = ["--package-db=" ++ x | x <- maybe [] splitSearchPath $ lookup "GHC_PACKAGE_PATH" env]+ (_, _, _, pid) <- createProcess $+ (proc "cabal" $ "configure":db){env = Just $ filter ((/=) "GHC_PACKAGE_PATH" . fst) env}+ ExitSuccess <- waitForProcess pid++ withGhcid [] $ \require -> do+ require [allGoodMessage]+ orig <- readFile' "src/Literate.lhs"+ append "src/Literate.lhs" "> x"+ require ["src/Literate.lhs:5:3","Parse error:"]+ write "src/Literate.lhs" orig+ require [allGoodMessage]
+ test/Test/Parser.hs view
@@ -0,0 +1,230 @@+-- | Test the message parser+module Test.Parser(parserTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Language.Haskell.Ghcid.Parser+import Language.Haskell.Ghcid.Types+++parserTests :: TestTree+parserTests = testGroup "Parser tests"+ [testParseShowModules+ ,testParseShowPaths+ ,testParseLoad+ ,testParseLoadGhc82+ ,testParseLoadNoPositionError+ ,testParseLoadSpans+ ,testParseLoadCycles+ ,testParseLoadCyclesSelf+ ,testParseLoadEscapeCodes+ ,testMissingFile+ ]++testParseShowModules :: TestTree+testParseShowModules = testCase "Show Modules" $ parseShowModules+ ["Main ( src/Main.hs, interpreted )"+ ,"AI.Neural.WiscDigit ( src/AI/Neural/WiscDigit.hs, interpreted )"+ ] @?=+ [("Main","src/Main.hs")+ ,("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 )"+ ,"GHCi.hs:70:1: Parse error: naked expression at top level"+ ,"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"+ ,"GHCi.hs:81:1: Warning: Defined but not used: `foo'"+ ,"C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase+ ,"src\\Haskell.hs:4:23:"+ ," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"+ ,"src\\Boot.hs-boot:2:8:"+ ," File name does not match module name:"+ ," Saw: `BootX'"+ ," Expected: `Boot'"+ ] @?=+ [Loading "GHCi" "GHCi.hs"+ ,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+testParseLoadGhc82 = testCase "GHC 8.2 Load Parsing" $ parseLoad+ ["[18 of 24] Compiling Physics ( Physics.hs, interpreted )"+ ,"Physics.hs:30:18: error: parse error on input ‘^*’"+ ," |"+ ,"30 | dx = ' ^* delta"+ ," | ^^"+ ,"Loaded GHCi configuration from C:\\Neil\\ghcid\\.ghci"+ ] @?=+ [Loading "Physics" "Physics.hs"+ ,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"+ ]++testParseLoadNoPositionError :: TestTree+testParseLoadNoPositionError = testCase "Load Parsing without source positions" $ parseLoad+ ["./Util.hs: error: [GHC-92213]"+ ," Module graph contains a cycle:"+ ," module ‘Util’ (./Util.hs)"+ ," imports module ‘Main’ (Main.hs)"+ ," which imports module ‘Util’ (./Util.hs)"+ ] @?=+ [Message Error "./Util.hs" (0,0) (0,0)+ ["./Util.hs: error: [GHC-92213]"+ ," Module graph contains a cycle:"+ ," module ‘Util’ (./Util.hs)"+ ," imports module ‘Main’ (Main.hs)"+ ," which imports module ‘Util’ (./Util.hs)"]+ ]++testMissingFile = testCase "Starting ghci with a non-existent filename" $ parseLoad+ ["<no location info>: error: can't find file: bob.hs"+ ] @?=+ [Message Error "<unknown>" (0,0) (0,0) ["<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 )"+ ,"GHCi.hs:70:1-2: Parse error: naked expression at top level"+ ,"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"+ ,"GHCi.hs:81:1-15: Warning: Defined but not used: `foo'"+ ,"C:\\GHCi.hs:82:1-17: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase+ ,"src\\Haskell.hs:4:23-24:"+ ," Warning: {-# SOURCE #-} unnecessary in import of `Boot'"+ ,"src\\Boot.hs-boot:2:8-5:"+ ," File name does not match module name:"+ ," Saw: `BootX'"+ ," Expected: `Boot'"+ ,"/src/TrieSpec.hs:(192,7)-(193,76): Warning:"+ ," A do-notation statement discarded a result of type ‘[()]’"+ ] @?=+ [Loading "GHCi" "GHCi.hs"+ ,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 ‘[()]’"]+ ]
+ test/Test/Util.hs view
@@ -0,0 +1,42 @@++-- | Test utility functions+module Test.Util where++import Test.Tasty+import Test.Tasty.HUnit+import Control.Monad+import Data.Maybe+import System.Environment++import Language.Haskell.Ghcid.Util+import Language.Haskell.Ghcid.Escape++utilsTests :: TestTree+utilsTests = testGroup "Utility tests"+ [dropPrefixTests+ ,wordWrapTests+ ]++dropPrefixTests :: TestTree+dropPrefixTests = testGroup "dropPrefix"+ [testCase "Prefix not found" $ dropPrefixRepeatedly "prefix" "string" @?= "string"+ ,testCase "Empty prefix" $ dropPrefixRepeatedly "" "string" @?= "string"+ ,testCase "Prefix found once" $ dropPrefixRepeatedly "str" "string" @?= "ing"+ ,testCase "Prefix found twice" $ dropPrefixRepeatedly "str" "strstring" @?= "ing"+ ]++wordWrapTests :: TestTree+wordWrapTests = testGroup "wordWrap"+ [testCase "Max 0" $ wordWrapE 4 0 (Esc "ab cd efgh") @?= [s"ab c",s"d ef",h"gh"]+ ,testCase "Max 2" $ wordWrapE 4 2 (Esc "ab cd efgh") @?= [h"ab ",h"cd ",h"efgh"]+ ]+ where h x = (Esc x, WrapHard)+ s x = (Esc x, WrapSoft)++isVerbose :: IO Bool+isVerbose = isJust <$> lookupEnv "GHCID_TEST_VERBOSE"++whenVerbose :: IO () -> IO ()+whenVerbose act = do+ verbose <- isVerbose+ when verbose act