diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# ghcid [![Hackage version](https://img.shields.io/hackage/v/ghcid.svg?label=Hackage)](https://hackage.haskell.org/package/ghcid) [![Stackage version](https://www.stackage.org/package/ghcid/badge/nightly?label=Stackage)](https://www.stackage.org/package/ghcid) [![Build status](https://img.shields.io/github/workflow/status/ndmitchell/ghcid/ci/master.svg)](https://github.com/ndmitchell/ghcid/actions) +# ghcid [![Hackage version](https://img.shields.io/hackage/v/ghcid.svg?label=Hackage)](https://hackage.haskell.org/package/ghcid) [![Stackage version](https://www.stackage.org/package/ghcid/badge/nightly?label=Stackage)](https://www.stackage.org/package/ghcid) [![Build status](https://img.shields.io/github/actions/workflow/status/ndmitchell/ghcid/ci.yml?branch=master)](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 +``` diff --git a/app/Ghcid.hs b/app/Ghcid.hs new file mode 100644 --- /dev/null +++ b/app/Ghcid.hs @@ -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 " + ,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] ++ "}" diff --git a/app/Language/Haskell/Ghcid/Terminal.hs b/app/Language/Haskell/Ghcid/Terminal.hs new file mode 100644 --- /dev/null +++ b/app/Language/Haskell/Ghcid/Terminal.hs @@ -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 diff --git a/app/Server.hs b/app/Server.hs new file mode 100644 --- /dev/null +++ b/app/Server.hs @@ -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 () diff --git a/app/Session.hs b/app/Session.hs new file mode 100644 --- /dev/null +++ b/app/Session.hs @@ -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 /= "" + predicate Loading{loadFile = loadFile} = loadFile /= "" + 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 diff --git a/app/Wait.hs b/app/Wait.hs new file mode 100644 --- /dev/null +++ b/app/Wait.hs @@ -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 diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -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 , jpmoresmau maintainer: Neil Mitchell -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 diff --git a/src/Ghcid.hs b/src/Ghcid.hs deleted file mode 100644 --- a/src/Ghcid.hs +++ /dev/null @@ -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 " - ,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] ++ "}" diff --git a/src/Language/Haskell/Ghcid.hs b/src/Language/Haskell/Ghcid.hs --- a/src/Language/Haskell/Ghcid.hs +++ b/src/Language/Haskell/Ghcid.hs @@ -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 diff --git a/src/Language/Haskell/Ghcid/Parser.hs b/src/Language/Haskell/Ghcid/Parser.hs --- a/src/Language/Haskell/Ghcid/Parser.hs +++ b/src/Language/Haskell/Ghcid/Parser.hs @@ -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 /= "" + , "error:" `isPrefixOfE` trimStartE rest + , (msg,las) <- span leadingWhitespaceE xs + = Message Error file (0,0) (0,0) (map fromEsc $ x:msg) : f las + -- : can't find file: FILENAME f (x:xs) | Just file <- stripPrefixE ": 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 diff --git a/src/Language/Haskell/Ghcid/Terminal.hs b/src/Language/Haskell/Ghcid/Terminal.hs deleted file mode 100644 --- a/src/Language/Haskell/Ghcid/Terminal.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Ghcid/Util.hs b/src/Language/Haskell/Ghcid/Util.hs --- a/src/Language/Haskell/Ghcid/Util.hs +++ b/src/Language/Haskell/Ghcid/Util.hs @@ -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 diff --git a/src/Session.hs b/src/Session.hs deleted file mode 100644 --- a/src/Session.hs +++ /dev/null @@ -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 /= "" - predicate Loading{loadFile = loadFile} = loadFile /= "" - 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 diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -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 - ] diff --git a/src/Test/API.hs b/src/Test/API.hs deleted file mode 100644 --- a/src/Test/API.hs +++ /dev/null @@ -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 - ] diff --git a/src/Test/Common.hs b/src/Test/Common.hs deleted file mode 100644 --- a/src/Test/Common.hs +++ /dev/null @@ -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" [] diff --git a/src/Test/Ghcid.hs b/src/Test/Ghcid.hs deleted file mode 100644 --- a/src/Test/Ghcid.hs +++ /dev/null @@ -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:"] --} diff --git a/src/Test/Parser.hs b/src/Test/Parser.hs deleted file mode 100644 --- a/src/Test/Parser.hs +++ /dev/null @@ -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 - [": error: can't find file: bob.hs" - ] @?= - [Message Error "" (0,0) (0,0) [": 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 ‘[()]’"] - ] diff --git a/src/Test/Util.hs b/src/Test/Util.hs deleted file mode 100644 --- a/src/Test/Util.hs +++ /dev/null @@ -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) diff --git a/src/Wait.hs b/src/Wait.hs deleted file mode 100644 --- a/src/Wait.hs +++ /dev/null @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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 + ] diff --git a/test/Test/API.hs b/test/Test/API.hs new file mode 100644 --- /dev/null +++ b/test/Test/API.hs @@ -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 () diff --git a/test/Test/Common.hs b/test/Test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Common.hs @@ -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 diff --git a/test/Test/Ghcid.hs b/test/Test/Ghcid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ghcid.hs @@ -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] diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Test/Parser.hs @@ -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 + [": error: can't find file: bob.hs" + ] @?= + [Message Error "" (0,0) (0,0) [": 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 ‘[()]’"] + ] diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util.hs @@ -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