diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,10 @@ Changelog for ghcid +0.6.6 + #89, exit sooner when the child process exits unexpectedly + Add Eq instance for Ghci + #88, add a --project flag + Rename --notitle flag to --no-title 0.6.5 #82, properly deal with warning messages including spans #78, support boot files better diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -31,6 +31,10 @@ Please [report any bugs](https://github.com/ndmitchell/ghcid/issues) you find. +### Ghcid Integration + +There are a few tools that integrate Ghcid into editors, see the [plugins](plugins/) folder for currently supported integrations. + ### FAQ * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -1,7 +1,7 @@ -cabal-version: >= 1.10 +cabal-version: >= 1.18 build-type: Simple name: ghcid -version: 0.6.5 +version: 0.6.6 license: BSD3 license-file: LICENSE category: Development diff --git a/src/Ghcid.hs b/src/Ghcid.hs --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -36,11 +36,12 @@ ,arguments :: [String] ,test :: [String] ,warnings :: Bool - ,nostatus :: Bool + ,no_status :: Bool ,height :: Maybe Int ,width :: Maybe Int ,topmost :: Bool - ,notitle :: Bool + ,no_title :: Bool + ,project :: String ,reload :: [FilePath] ,restart :: [FilePath] ,directory :: FilePath @@ -54,11 +55,12 @@ ,arguments = [] &= args &= typ "MODULE" ,test = [] &= name "T" &= typ "EXPR" &= help "Command to run after successful loading" ,warnings = False &= name "W" &= help "Allow tests to run even with warnings" - ,nostatus = False &= name "S" &= explicit &= name "no-status" &= help "Suppress status messages" + ,no_status = False &= name "S" &= help "Suppress status messages" ,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)" - ,notitle = False &= help "Don't update the shell title/icon" + ,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)" ,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" @@ -192,14 +194,15 @@ if null test || countErrors /= 0 || (countWarnings /= 0 && not warnings) then Nothing else Just $ intercalate "\n" test - unless notitle $ setWindowIcon $ + unless no_title $ setWindowIcon $ if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK - let updateTitle extra = unless notitle $ setTitle $ + let updateTitle extra = unless no_title $ setTitle $ let f n msg = if n == 0 then "" else show n ++ " " ++ msg ++ ['s' | n > 1] in (if countErrors == 0 && countWarnings == 0 then allGoodMessage else f countErrors "error" ++ - (if countErrors > 0 && countWarnings > 0 then ", " else "") ++ f countWarnings "warning") ++ - " " ++ extra ++ [' ' | extra /= ""] ++ "- " ++ takeFileName curdir + (if countErrors > 0 && countWarnings > 0 then ", " else "") ++ f countWarnings "warning") ++ + " " ++ extra ++ [' ' | extra /= ""] ++ "- " ++ + (if null project then takeFileName curdir else project) updateTitle $ if isJust test then "(running test)" else "" outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test] @@ -220,7 +223,7 @@ updateTitle "(test done)" reason <- nextWait $ restart ++ reload ++ loaded - unless nostatus $ outputFill Nothing $ "Reloading..." : map (" " ++) reason + unless no_status $ outputFill Nothing $ "Reloading..." : map (" " ++) reason restartTimes2 <- mapM getModTime restart if restartTimes == restartTimes2 then do nextWait <- waitFiles waiter 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 @@ -20,6 +20,7 @@ import Data.Maybe import Data.IORef import Control.Applicative +import Data.Unique import System.Console.CmdArgs.Verbosity @@ -37,8 +38,12 @@ data Ghci = Ghci {ghciProcess :: ProcessHandle ,ghciInterrupt :: IO () - ,ghciExec :: String -> (Stream -> String -> IO ()) -> IO ()} + ,ghciExec :: String -> (Stream -> String -> IO ()) -> IO () + ,ghciUnique :: Unique + } +instance Eq Ghci where + a == b = ghciUnique a == ghciUnique b -- | Start GHCi, returning a function to perform further operation, as well as the result of the initial loading. -- If you do not call 'stopGhci' then the underlying process may be leaked. @@ -132,6 +137,7 @@ stop <- syncFresh void $ consume2 "Interrupt" $ \_ s -> return $ if stop s then Just () else Nothing + ghciUnique <- newUnique let ghci = Ghci{..} -- Now wait for 'GHCi, version' to appear before sending anything real, required for #57 diff --git a/src/Language/Haskell/Ghcid/Terminal.hs b/src/Language/Haskell/Ghcid/Terminal.hs --- a/src/Language/Haskell/Ghcid/Terminal.hs +++ b/src/Language/Haskell/Ghcid/Terminal.hs @@ -24,11 +24,16 @@ iCON_BIG = 1 iCON_SMALL = 0 +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif -foreign import stdcall unsafe "windows.h GetConsoleWindow" +foreign import CALLCONV unsafe "windows.h GetConsoleWindow" getConsoleWindow :: IO HWND -foreign import stdcall unsafe "windows.h SetWindowPos" +foreign import CALLCONV unsafe "windows.h SetWindowPos" setWindowPos :: HWND -> HWND -> Int -> Int -> Int -> Int -> Word32 -> IO Bool #endif diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -27,14 +27,11 @@ ,command :: IORef (Maybe String) -- ^ The last command passed to sessionStart ,warnings :: IORef [Load] -- ^ The warnings from the last load ,running :: Var Bool -- ^ Am I actively running an async command + ,withThread :: ThreadId -- ^ Thread that called withSession } --- | Ensure an action runs off the main thread, so can't get hit with Ctrl-C exceptions. --- Disabled because it plays havoc with tests and cleaning up quickly enough. -ctrlC :: IO a -> IO a -ctrlC = id -- join . onceFork - +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 @@ -45,18 +42,28 @@ command <- newIORef Nothing warnings <- newIORef [] running <- newVar False - ctrlC (f Session{..}) `finally` do + debugShutdown "Starting session" + withThread <- myThreadId + f Session{..} `finally` do + debugShutdown "Start finally" modifyVar_ running $ const $ return False whenJustM (readIORef ghci) $ \v -> do writeIORef ghci Nothing - ctrlC $ kill v + 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 = ignore $ do - timeout 5 $ quit ghci + timeout 5 $ do + debugShutdown "Before quit" + ignore $ quit ghci + debugShutdown "After quit" + debugShutdown "Before terminateProcess" terminateProcess $ process ghci + debugShutdown "After terminateProcess" -- | Spawn a new Ghci process at a given command line. Returns the load messages, plus @@ -65,12 +72,26 @@ sessionStart Session{..} cmd = do modifyVar_ running $ const $ return False writeIORef command $ Just cmd - val <- readIORef ghci - whenJust val $ void . forkIO . kill - writeIORef ghci Nothing + + -- cleanup any old instances + whenJustM (readIORef ghci) $ \v -> do + writeIORef ghci Nothing + void $ forkIO $ kill v + + -- start the new outStrLn $ "Loading " ++ cmd ++ " ..." (v, messages) <- startGhci cmd Nothing $ const outStrLn writeIORef ghci $ Just v + + -- install a handler + forkIO $ do + 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" + + -- handle what the process returned messages <- return $ mapMaybe tidyMessage messages writeIORef warnings [m | m@Message{..} <- messages, loadSeverity == Warning] return (messages, nubOrd $ map loadFile messages) diff --git a/src/Test/Ghcid.hs b/src/Test/Ghcid.hs --- a/src/Test/Ghcid.hs +++ b/src/Test/Ghcid.hs @@ -71,7 +71,7 @@ done <- newBarrier res <- bracket (flip forkFinally (const $ signalBarrier done ()) $ - withArgs (["--notitle","--no-status"]++args) $ + withArgs (["--no-title","--no-status"]++args) $ mainWithTerminal (return (100, 50)) output) killThread $ \_ -> script require waitBarrier done