diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,12 @@ Changelog for GHCiD +0.6 + #38, implement loading with stack + Add process, quit and execStream to the API + #29, add interrupt function + Add Data instances for the types + Make stopGhci more effective, now kills the underlying process + Make startGhci take a function to write the buffer to 0.5.1 #17, deal with recursive modules errors properly #50, use -fno-code when not running tests (about twice as fast) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,9 +4,9 @@ _Acknowledgements:_ This project incorporates significant work from [JPMoresmau](https://github.com/JPMoresmau), who is listed as a co-author. -**Using it** +### Using it -Run `cabal update && cabal install ghcid` to install it as normal. Then run `ghcid --height=8 --topmost "--command=ghci Main.hs"`. The `height` is the number of lines you are going to resize your console window to (defaults to height of the console). The `topmost` is to make the window sit above all others, which only works on Windows. The `command` is how you start your project in `ghci`. If you omit `--command` then it will default to `ghci` if you have a `.ghci` file in the current directory, otherwise it will default to `cabal repl`. +Run `cabal update && cabal install ghcid` to install it as normal. Then run `ghcid --height=8 --topmost "--command=ghci Main.hs"`. The `height` is the number of lines you are going to resize your console window to (defaults to height of the console). The `topmost` is to make the window sit above all others, which only works on Windows. The `command` is how you start your project in `ghci`. If you omit `--command` then it will default to `stack ghci` if you have the `stack.yaml` file and `.stack-work` directory, default to `ghci` if you have a `.ghci` file in the current directory, and otherwise default to `cabal repl`. 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): @@ -16,7 +16,7 @@ After that, resize your console and make it so you can see it while working in your editor. On Windows the console will automatically sit on top of all other windows. On Linux, you probably want to use your window manager to make it topmost or use a [tiling window manager](http://xmonad.org/). -**What you get** +### What you get On every save you'll see a list of the errors and warnings in your project. It uses `ghci` under the hood, so even relatively large projects should update their status pretty quickly. As an example: @@ -31,8 +31,7 @@ Please [report any bugs](https://github.com/ndmitchell/ghcid/issues) you find. -**FAQ** +### FAQ * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). * _If I delete a file and put it back it gets stuck._ Yes, that's a [bug in GHCi](https://ghc.haskell.org/trac/ghc/ticket/9648). If you see GHCi getting confused just kill `ghcid` and start it again. -* _It doesn't work with Stack._ Pass `-c "stack ghci"`. Work is ongoing to improve the Stack integration (mostly waiting on features/changes/fixes on the Stack side). diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: ghcid -version: 0.5.1 +version: 0.6 license: BSD3 license-file: LICENSE category: Development @@ -23,9 +23,9 @@ location: https://github.com/ndmitchell/ghcid.git library - hs-source-dirs: src - default-language: Haskell2010 - build-depends: + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4, filepath, time, @@ -34,67 +34,76 @@ process >= 1.1, cmdargs >= 0.10, terminal-size >= 0.3 - if os(windows) - build-depends: Win32 - other-modules: - Paths_ghcid, - Language.Haskell.Ghcid.Types, - Language.Haskell.Ghcid.Parser, - Language.Haskell.Ghcid.Terminal, - Language.Haskell.Ghcid.Util - exposed-modules: Language.Haskell.Ghcid + if os(windows) + build-depends: Win32 + else + build-depends: unix + exposed-modules: + Language.Haskell.Ghcid + other-modules: + Paths_ghcid, + Language.Haskell.Ghcid.Types, + Language.Haskell.Ghcid.Parser, + Language.Haskell.Ghcid.Terminal, + Language.Haskell.Ghcid.Util + executable ghcid - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -main-is Ghcid.main -threaded - main-is: Ghcid.hs - build-depends: - base == 4.*, - filepath, - time, - directory, - containers, - fsnotify, - extra >= 1.2, - process >= 1.1, - cmdargs >= 0.10, - ansi-terminal, - terminal-size >= 0.3 - if os(windows) - build-depends: Win32 - other-modules: - Language.Haskell.Ghcid.Types, - Language.Haskell.Ghcid.Parser, - Language.Haskell.Ghcid.Terminal, - Language.Haskell.Ghcid.Util, - Language.Haskell.Ghcid, - Wait + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -main-is Ghcid.main -threaded + main-is: Ghcid.hs + build-depends: + base == 4.*, + filepath, + time, + directory, + containers, + fsnotify, + extra >= 1.2, + process >= 1.1, + cmdargs >= 0.10, + ansi-terminal, + terminal-size >= 0.3 + if os(windows) + build-depends: Win32 + else + build-depends: unix + other-modules: + Language.Haskell.Ghcid.Types, + Language.Haskell.Ghcid.Parser, + Language.Haskell.Ghcid.Terminal, + Language.Haskell.Ghcid.Util, + Language.Haskell.Ghcid, + Session, + Wait test-suite ghcid_test - type: exitcode-stdio-1.0 - ghc-options: -rtsopts -main-is Test.main -threaded -with-rtsopts=-K1K - default-language: Haskell2010 - build-depends: - base >= 4, - filepath, - time, - directory, - process, - containers, - fsnotify, - extra >= 1.2, - ansi-terminal, - terminal-size >= 0.3, - cmdargs, - tasty, - tasty-hunit - if os(windows) - build-depends: Win32 - hs-source-dirs: src - main-is: Test.hs - other-modules: - Test.Parser, - Test.HighLevel, - Test.Util, - Test.Polling + type: exitcode-stdio-1.0 + hs-source-dirs: src + main-is: Test.hs + ghc-options: -rtsopts -main-is Test.main -threaded -with-rtsopts=-K1K + default-language: Haskell2010 + build-depends: + base >= 4, + filepath, + time, + directory, + process, + containers, + fsnotify, + extra >= 1.2, + ansi-terminal, + terminal-size >= 0.3, + cmdargs, + tasty, + tasty-hunit + if os(windows) + build-depends: Win32 + else + build-depends: unix + other-modules: + Test.Parser, + Test.HighLevel, + Test.Util, + Test.Polling diff --git a/src/Ghcid.hs b/src/Ghcid.hs --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, TupleSections #-} +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, TupleSections #-} {-# OPTIONS_GHC -fno-cse #-} -- | The application entry point module Ghcid(main, runGhcid) where -import Control.Applicative import Control.Exception import Control.Monad.Extra -import Control.Concurrent.Extra import Data.List.Extra import Data.Maybe import Data.Tuple.Extra import Data.Version +import Session import qualified System.Console.Terminal.Size as Term import System.Console.CmdArgs import System.Console.ANSI @@ -26,7 +25,6 @@ import Language.Haskell.Ghcid.Util import Language.Haskell.Ghcid.Types import Wait -import Prelude -- | Command line options @@ -91,8 +89,15 @@ let cabal = filter ((==) ".cabal" . takeExtension) files let opts = ["-fno-code" | isNothing test] return $ case () of - _ | ".ghci" `elem` files -> f ("ghci":opts) [".ghci"] - | "stack.yaml" `elem` files, False -> f ("stack ghci":map ("--ghci-options=" ++) opts) ["stack.yaml"] -- see #130 + _ | "stack.yaml" `elem` files, ".stack-work" `elem` files -> + let flags = if null arguments then + "stack ghci --test" : + ["--no-load" | ".ghci" `elem` files] ++ + map ("--ghci-options=" ++) opts + else + "stack exec --test --" : opts + in f flags $ "stack.yaml":cabal + | ".ghci" `elem` files -> f ("ghci":opts) [".ghci"] | cabal /= [] -> f (if arguments == [] then "cabal repl":map ("--ghc-options=" ++) opts else "cabal exec -- ghci":opts) cabal | otherwise -> f ("ghci":opts) [] where @@ -103,13 +108,8 @@ | otherwise = x --- ensure the action runs off the main thread -ctrlC :: IO () -> IO () -ctrlC = join . onceFork - - main :: IO () -main = withWindowIcon $ ctrlC $ do +main = withWindowIcon $ withSession $ \session -> do opts <- cmdArgsRun options withCurrentDirectory (directory opts) $ do opts@Options{..} <- autoOptions opts @@ -126,7 +126,7 @@ return (f width 80 (pred . fst), f height 8 snd) withWaiterNotify $ \waiter -> handle (\(UnexpectedExit cmd _) -> putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly") $ - runGhcid waiter (nubOrd restart) command outputfile test height (not notitle) $ \xs -> do + runGhcid session waiter (nubOrd restart) command outputfile test height (not notitle) $ \xs -> do outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity] putStr $ concatMap ((:) '\n' . snd) x @@ -137,8 +137,8 @@ data Style = Plain | Bold deriving Eq -runGhcid :: Waiter -> [FilePath] -> String -> [FilePath] -> Maybe String -> IO (Int,Int) -> Bool -> ([(Style,String)] -> IO ()) -> IO () -runGhcid waiter restart command outputfiles test size titles output = do +runGhcid :: Session -> Waiter -> [FilePath] -> String -> [FilePath] -> Maybe String -> IO (Int,Int) -> Bool -> ([(Style,String)] -> IO ()) -> IO () +runGhcid session waiter restart command outputfiles test size titles output = do let outputFill :: Maybe (Int, [Load]) -> [String] -> IO () outputFill load msg = do (width, height) <- size @@ -149,40 +149,20 @@ output $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"") restartTimes <- mapM getModTime restart - outStrLn $ "Loading " ++ command ++ " ..." - nextWait <- waitFiles waiter - (ghci,messages) <- startGhci command Nothing True curdir <- getCurrentDirectory - -- fire, given a waiter, the messages, and the warnings from last time - let fire nextWait messages warnings = do - let f m@Message{} = m{loadMessage = filter (not . ignoreMessageLine) $ loadMessage m} - f x = x - messages <- return $ map f $ filter (not . ignoreMessage) messages - - loaded <- map snd <$> showModules ghci + -- fire, given a waiter, the messages/loaded + let fire nextWait (messages, loaded) = do let loadedCount = length loaded - -- some may have reloaded, but caused an error, and thus not be in the loaded set - let reloaded = nubOrd $ filter (/= "") $ map loadFile messages - - let wait = nubOrd $ loaded ++ reloaded whenLoud $ do outStrLn $ "%MESSAGES: " ++ show messages outStrLn $ "%LOADED: " ++ show loaded - when (null wait && isNothing warnings) $ do - putStrLn $ "\nNo files loaded, did not start GHCi properly.\nCommand: " ++ command - exitFailure - - -- 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 <- return $ messages ++ filter validWarn (fromMaybe [] warnings) let (countErrors, countWarnings) = both sum $ unzip [if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []] - test <- return $ if countErrors == 0 then test else Nothing + test <- return $ if countErrors == 0 && countWarnings == 0 then test else Nothing - when titles $ changeWindowIcon $ + when titles $ setWindowIcon $ if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK let updateTitle extra = when titles $ setTitle $ @@ -195,41 +175,30 @@ outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test] forM_ outputfiles $ \file -> writeFile file $ unlines $ map snd $ prettyOutput loadedCount $ filter isMessage messages - whenJust test $ \test -> do - res <- exec ghci test - outputFill (Just (loadedCount, messages)) $ fromMaybe res $ stripSuffix ["*** Exception: ExitSuccess"] res - updateTitle "" - - when (null wait) $ do + when (null loaded) $ do putStrLn $ "No files loaded, nothing to wait for. Fix the last error and restart." exitFailure - reason <- nextWait $ restart ++ wait + whenJust test $ \t -> do + whenLoud $ outStrLn $ "%TESTING: " ++ t + sessionExecAsync session t $ do + whenLoud $ outStrLn "%TESTING: Completed" + updateTitle "(test done)" + + reason <- nextWait $ restart ++ loaded outputFill Nothing $ "Reloading..." : map (" " ++) reason restartTimes2 <- mapM getModTime restart if restartTimes == restartTimes2 then do nextWait <- waitFiles waiter - let warnings = [m | m@Message{..} <- messages, loadSeverity == Warning] - messages <- reload ghci - fire nextWait messages $ Just warnings + fire nextWait =<< sessionReload session else do - stopGhci ghci - runGhcid waiter restart command outputfiles test size titles output - - fire nextWait messages Nothing - - --- | Ignore messages that GHC shouldn't really generate. -ignoreMessage :: Load -> Bool -ignoreMessage Message{loadSeverity=Warning, loadMessage=[_,x]} - = x `elem` [" -O conflicts with --interactive; -O ignored."] -ignoreMessage _ = False + runGhcid session waiter restart command outputfiles test size titles output --- | Ignore lines in messages that are pointless. -ignoreMessageLine :: String -> Bool -ignoreMessageLine x = any (`isPrefixOf` x) xs - where - xs = [" except perhaps to import instances from" - ," To import instances alone, use: import "] + nextWait <- waitFiles waiter + (messages, loaded) <- sessionStart session command + when (null loaded) $ do + putStrLn $ "\nNo files loaded, GHCi is not working properly.\nCommand: " ++ command + exitFailure + fire nextWait (messages, loaded) -- | Given an available height, and a set of messages to display, show them as best you can. 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 @@ -1,20 +1,23 @@ +{-# LANGUAGE RecordWildCards #-} --- | The entry point of the library +-- | Library for spawning and working with Ghci sessions. module Language.Haskell.Ghcid( - Ghci, GhciError(..), + Ghci, GhciError(..), Stream(..), Load(..), Severity(..), - startGhci, stopGhci, - showModules, reload, exec + startGhci, stopGhci, interrupt, process, execStream, + showModules, reload, exec, quit ) where import System.IO import System.IO.Error import System.Process +import System.Time.Extra import Control.Concurrent.Extra import Control.Exception.Extra import Control.Monad.Extra import Data.Function -import Data.List +import Data.List.Extra +import Data.Maybe import Data.IORef import Control.Applicative @@ -25,73 +28,171 @@ import Language.Haskell.Ghcid.Util import Prelude + +-- | A GHCi session. Created with 'startGhci', closed with 'stopGhci'. +-- +-- The interactions with a 'Ghci' session must all occur single-threaded, +-- or an error will be raised. The only exception is 'interrupt', which aborts +-- a running computation, or does nothing if no computation is running. +data Ghci = Ghci + {ghciProcess :: ProcessHandle + ,ghciInterrupt :: IO () + ,ghciExec :: String -> (Stream -> String -> IO ()) -> IO ()} + + -- | Start GHCi, returning a function to perform further operation, as well as the result of the initial loading. --- Pass True to write out messages produced while loading, useful if invoking something like "cabal repl" +-- If you do not call 'stopGhci' then the underlying process may be leaked. +-- The callback will be given the messages produced while loading, useful if invoking something like "cabal repl" -- which might compile dependent packages before really loading. -startGhci :: String -> Maybe FilePath -> Bool -> IO (Ghci, [Load]) -startGhci cmd directory echo = do - (Just inp, Just out, Just err, _) <- - createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, cwd=directory} +startGhci :: String -> Maybe FilePath -> (Stream -> String -> IO ()) -> IO (Ghci, [Load]) +startGhci cmd directory echo0 = do + (Just inp, Just out, Just err, ghciProcess) <- + createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, cwd=directory, create_group=True} + hSetBuffering out LineBuffering hSetBuffering err LineBuffering hSetBuffering inp LineBuffering - lock <- newLock -- ensure only one person talks to ghci at a time - let prefix = "#~GHCID-START~#" - let finish = "#~GHCID-FINISH~#" - hPutStrLn inp $ ":set prompt " ++ prefix + -- I'd like the GHCi prompt to go away, but that's not possible, so I set it to a special + -- string and filter that out. + let ghcid_prefix = "#~GHCID-START~#" + let removePrefix = dropPrefixRepeatedly ghcid_prefix + hPutStrLn inp $ ":set prompt " ++ ghcid_prefix hPutStrLn inp ":set -fno-break-on-exception -fno-break-on-error" -- see #43 - echo <- newIORef echo - -- consume from a handle, produce an MVar with either Just and a message, or Nothing (stream closed) - let consume h name = do - result <- newEmptyMVar -- the end result - buffer <- newVar [] -- the things to go in result - forkIO $ fix $ \rec -> do + -- At various points I need to ensure everything the user is waiting for has completed + -- So I send messages on stdout/stderr and wait for them to arrive + syncCount <- newVar 0 + let syncReplay = do + i <- readVar syncCount + let msg = "#~GHCID-FINISH-" ++ show i ++ "~#" + hPutStrLn inp $ "Prelude.putStrLn " ++ show msg ++ "\nPrelude.error " ++ show msg + return $ isInfixOf msg + let syncFresh = do + modifyVar_ syncCount $ return . succ + syncReplay + + -- Consume from a stream until EOF (return Nothing) or some predicate returns Just + let consume :: Stream -> (String -> IO (Maybe a)) -> IO (Maybe a) + consume name finish = do + let h = if name == Stdout then out else err + fix $ \rec -> do el <- tryBool isEOFError $ hGetLine h case el of - Left _ -> putMVar result Nothing + Left _ -> return Nothing Right l -> do - whenLoud $ outStrLn $ "%" ++ name ++ ": " ++ l - whenM (readIORef echo) $ - unless (any (`isInfixOf` l) [prefix, finish]) $ outStrLn l - if finish `isInfixOf` l - then do - buf <- modifyVar buffer $ \old -> return ([], reverse old) - putMVar result $ Just buf - else - modifyVar_ buffer $ return . (dropPrefixRepeatedly prefix l:) - rec - return result + whenLoud $ outStrLn $ "%" ++ upper (show name) ++ ": " ++ l + res <- finish $ removePrefix l + case res of + Nothing -> rec + Just a -> return $ Just a - outs <- consume out "GHCOUT" - errs <- consume err "GHCERR" + let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a) + consume2 msg finish = do + res1 <- onceFork $ consume Stdout (finish Stdout) + res2 <- consume Stderr (finish Stderr) + res1 <- res1 + case liftM2 (,) res1 res2 of + Nothing -> throwIO $ UnexpectedExit cmd msg + Just v -> return v - let f s = withLock lock $ do - whenLoud $ outStrLn $ "%GHCINP: " ++ s - hPutStrLn inp $ s ++ "\nPrelude.putStrLn " ++ show finish ++ "\nPrelude.error " ++ show finish - outC <- takeMVar outs - errC <- takeMVar errs - case liftM2 (++) outC errC of - Nothing -> throwIO $ UnexpectedExit cmd s - Just msg -> return msg - r <- parseLoad <$> f "" - writeIORef echo False - return (Ghci f,r) + -- held while interrupting, and briefly held when starting an exec + -- ensures exec values queue up behind an ongoing interrupt and no two interrupts run at once + isInterrupting <- newLock --- | Show modules + -- is anyone running running an exec statement, ensure only one person talks to ghci at a time + isRunning <- newLock + + let ghciExec command echo = do + withLock isInterrupting $ return () + res <- withLockTry isRunning $ do + whenLoud $ outStrLn $ "%GHCINP: " ++ command + hPutStrLn inp command + stop <- syncFresh + void $ consume2 command $ \strm s -> + if stop s then return $ Just () else do echo strm s; return Nothing + when (isNothing res) $ + fail "Ghcid.exec, computation is already running, must be used single-threaded" + + let ghciInterrupt = withLock isInterrupting $ do + whenM (fmap isNothing $ withLockTry isRunning $ return ()) $ do + whenLoud $ outStrLn "%INTERRUPT" + interruptProcessGroupOf ghciProcess + -- let the person running ghciExec finish, since their sync messages + -- may have been the ones that got interrupted + syncReplay + -- now wait for the person doing ghciExec to have actually left the lock + withLock isRunning $ return () + -- there may have been two syncs sent, so now do a fresh sync to clear everything + stop <- syncFresh + void $ consume2 "Interrupt" $ \_ s -> return $ if stop s then Just () else Nothing + + let ghci = Ghci{..} + r <- parseLoad <$> execBuffer ghci "" echo0 + return (ghci, r) + + +-- | Execute a command, calling a callback on each response. +-- The callback will be called single threaded. +execStream :: Ghci -> String -> (Stream -> String -> IO ()) -> IO () +execStream = ghciExec + +-- | Interrupt Ghci, stopping the current computation (if any), +-- but leaving the process open to new input. +interrupt :: Ghci -> IO () +interrupt = ghciInterrupt + +-- | Obtain the progress handle behind a GHCi instance. +process :: Ghci -> ProcessHandle +process = ghciProcess + + +--------------------------------------------------------------------- +-- SUGAR HELPERS + +-- | Execute a command, calling a callback on each response. +-- The callback will be called single threaded. +execBuffer :: Ghci -> String -> (Stream -> String -> IO ()) -> IO [String] +execBuffer ghci cmd echo = do + stdout <- newIORef [] + stderr <- newIORef [] + execStream ghci cmd $ \i s -> do + modifyIORef (if i == Stdout then stdout else stderr) (s:) + echo i s + reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout) + +-- | Send a command, get lines of result. Must be called single-threaded. +exec :: Ghci -> String -> IO [String] +exec ghci cmd = execBuffer ghci cmd $ \_ _ -> return () + +-- | List the modules currently loaded, with module name and source file. showModules :: Ghci -> IO [(String,FilePath)] showModules ghci = parseShowModules <$> exec ghci ":show modules" --- | reload modules +-- | Perform a reload, list the messages that reload generated. reload :: Ghci -> IO [Load] reload ghci = parseLoad <$> exec ghci ":reload" --- | Stop GHCi -stopGhci :: Ghci -> IO () -stopGhci ghci = handle (\UnexpectedExit{} -> return ()) $ void $ exec ghci ":quit" +-- | Send @:quit@ and wait for the process to quit. +quit :: Ghci -> IO () +quit ghci = do + interrupt ghci + handle (\UnexpectedExit{} -> return ()) $ void $ exec ghci ":quit" + -- Add ignore because sometimes I get a message about an invalid handle, + -- and I've got no idea why - but exceptions here probably mean the thing already died. + -- Windows only, and Appveyor only. + ignore $ + void $ waitForProcess $ process ghci --- | Send a command, get lines of result -exec :: Ghci -> String -> IO [String] -exec (Ghci x) = x + +-- | Stop GHCi. Attempts to interrupt and execute @:quit:@, but if that doesn't complete +-- within 5 seconds it just terminates the process. +stopGhci :: Ghci -> IO () +stopGhci ghci = do + forkIO $ quit ghci + forkIO $ do + -- if nicely doesn't work, kill ghci as the process level + sleep 5 + terminateProcess $ process ghci + void $ waitForProcess $ process ghci 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 @@ -3,7 +3,7 @@ -- | Cross-platform operations for manipulating terminal console windows. module Language.Haskell.Ghcid.Terminal( terminalTopmost, - withWindowIcon, WindowIcon(..), changeWindowIcon + withWindowIcon, WindowIcon(..), setWindowIcon ) where #if defined(mingw32_HOST_OS) @@ -48,9 +48,9 @@ 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. -changeWindowIcon :: WindowIcon -> IO () +setWindowIcon :: WindowIcon -> IO () #if defined(mingw32_HOST_OS) -changeWindowIcon x = do +setWindowIcon x = do ico <- return $ case x of IconOK -> iDI_ASTERISK IconWarning -> iDI_EXCLAMATION @@ -62,10 +62,11 @@ sendMessage wnd wM_SETICON iCON_BIG $ fromIntegral $ castPtrToUINTPtr icon return () #else -changeWindowIcon _ = return () +setWindowIcon _ = return () #endif +-- | Run an operation in which you call setWindowIcon withWindowIcon :: IO a -> IO a #if defined(mingw32_HOST_OS) withWindowIcon act = do diff --git a/src/Language/Haskell/Ghcid/Types.hs b/src/Language/Haskell/Ghcid/Types.hs --- a/src/Language/Haskell/Ghcid/Types.hs +++ b/src/Language/Haskell/Ghcid/Types.hs @@ -2,26 +2,28 @@ -- | The types types that we use in Ghcid module Language.Haskell.Ghcid.Types( - Ghci(..), GhciError(..), + GhciError(..), + Stream(..), Load(..), Severity(..), isMessage ) where -import Data.Typeable +import Data.Data import Control.Exception.Base (Exception) --- | A GHCi session. Created with 'startGhci'. -newtype Ghci = Ghci (String -> IO [String]) - -- | GHCi shut down data GhciError = UnexpectedExit String String - deriving (Show,Eq,Ord,Typeable) + deriving (Show,Eq,Ord,Typeable,Data) -- | Make GhciError an exception instance Exception GhciError +-- | The stream Ghci is talking over. +data Stream = Stdout | Stderr + deriving (Show,Eq,Ord,Bounded,Enum,Read,Typeable,Data) + -- | Severity of messages data Severity = Warning | Error - deriving (Show,Eq,Ord,Bounded,Enum,Typeable) + deriving (Show,Eq,Ord,Bounded,Enum,Read,Typeable,Data) -- | Load messages data Load 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,3 +1,4 @@ + -- | Utility functions module Language.Haskell.Ghcid.Util( dropPrefixRepeatedly, diff --git a/src/Session.hs b/src/Session.hs new file mode 100644 --- /dev/null +++ b/src/Session.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | A persistent version of the Ghci session, encoding lots of semantics on top. +-- Not suitable for calling multithreaded. +module Session( + Session, withSession, + sessionStart, sessionRestart, sessionReload, + sessionExecAsync, + ) where + +import Language.Haskell.Ghcid +import Language.Haskell.Ghcid.Util +import Data.IORef +import System.Time.Extra +import System.Process +import Control.Exception.Extra +import Control.Concurrent.Extra +import Control.Monad.Extra +import Data.Maybe +import Data.List.Extra +import Control.Applicative +import Prelude + + +data Session = Session + {ghci :: IORef (Maybe Ghci) -- ^ The Ghci session, or Nothing if there is none + ,command :: IORef (Maybe String) -- ^ The last command passed to sessionStart + ,warnings :: IORef [Load] -- ^ The warnings from the last load + ,running :: Var Bool -- ^ Am I actively running an async command + } + + +-- | Ensure an action runs off the main thread, so can't get hit with Ctrl-C exceptions. +ctrlC :: IO a -> IO a +ctrlC = join . onceFork + + +-- | 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 [] + running <- newVar False + ctrlC (f $ Session{..}) `finally` do + modifyVar_ running $ const $ return False + whenJustM (readIORef ghci) $ \v -> do + writeIORef ghci Nothing + ctrlC $ kill v + + +-- | 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 + terminateProcess $ process ghci + + +-- | Spawn a new Ghci process at a given command line. Returns the load messages, plus +-- the list of files that were observed (both those loaded and those that failed to load). +sessionStart :: Session -> String -> IO ([Load], [FilePath]) +sessionStart Session{..} cmd = do + modifyVar_ running $ const $ return False + writeIORef command $ Just cmd + val <- readIORef ghci + whenJust val $ void . forkIO . kill + writeIORef ghci Nothing + outStrLn $ "Loading " ++ cmd ++ " ..." + (v, messages) <- startGhci cmd Nothing $ const outStrLn + writeIORef ghci $ Just v + messages <- return $ mapMaybe tidyMessage messages + writeIORef warnings [m | m@Message{..} <- messages, loadSeverity == Warning] + return (messages, nubOrd $ map loadFile messages) + + +-- | Call 'sessionStart' at the previous command. +sessionRestart :: Session -> IO ([Load], [FilePath]) +sessionRestart session@Session{..} = do + Just cmd <- readIORef command + sessionStart session cmd + + +-- | 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]) +sessionReload session@Session{..} = do + -- kill anything async, set stuck if you didn't succeed + old <- modifyVar running $ \b -> return (False, b) + stuck <- if not old then return False else do + Just ghci <- readIORef ghci + fmap isNothing $ timeout 5 $ interrupt ghci + + if stuck then sessionRestart session else do + -- actually reload + Just ghci <- readIORef ghci + messages <- mapMaybe tidyMessage <$> reload ghci + loaded <- map snd <$> showModules ghci + let reloaded = nubOrd $ filter (/= "") $ map loadFile messages + warn <- readIORef warnings + + -- 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 <- return $ messages ++ filter validWarn warn + + writeIORef warnings [m | m@Message{..} <- messages, loadSeverity == Warning] + return (messages, nubOrd $ loaded ++ reloaded) + + +-- | Run an exec operation asynchronously. Should not be a @:reload@ or similar. +-- Will be automatically aborted if it takes too long. +sessionExecAsync :: Session -> String -> IO () -> IO () +sessionExecAsync Session{..} cmd done = do + Just ghci <- readIORef ghci + modifyVar_ running $ const $ return True + void $ forkIO $ do + execStream ghci cmd $ \_ msg -> + when (msg /= "*** Exception: ExitSuccess") $ + outStrLn msg + old <- modifyVar running $ \b -> return (False, b) + -- don't fire Done if someone interrupted us + when old done + + +-- | Ignore entirely pointless messages and remove unnecessary lines. +tidyMessage :: Load -> Maybe Load +tidyMessage Message{loadSeverity=Warning, loadMessage=[_,x]} + | x == " -O conflicts with --interactive; -O ignored." = Nothing +tidyMessage m@Message{..} + = Just m{loadMessage = filter (\x -> not $ any (`isPrefixOf` 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/HighLevel.hs b/src/Test/HighLevel.hs --- a/src/Test/HighLevel.hs +++ b/src/Test/HighLevel.hs @@ -24,7 +24,7 @@ testStartRepl :: TestTree testStartRepl = testCase "Start cabal repl" $ withTestProject $ \root -> do - (ghci,load) <- startGhci "cabal repl" (Just root) True + (ghci,load) <- startGhci "cabal repl" (Just root) $ const putStrLn stopGhci ghci load @?= [ Loading "B.C" (normalise "src/B/C.hs") , Loading "A" (normalise "src/A.hs") @@ -33,7 +33,7 @@ testShowModules :: TestTree testShowModules = testCase "Show Modules" $ withTestProject $ \root -> do - (ghci,_) <- startGhci "cabal repl" (Just root) True + (ghci,_) <- startGhci "cabal repl" (Just root) $ const putStrLn mods <- showModules ghci stopGhci ghci mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] diff --git a/src/Test/Polling.hs b/src/Test/Polling.hs --- a/src/Test/Polling.hs +++ b/src/Test/Polling.hs @@ -18,6 +18,7 @@ import Test.Tasty.HUnit import Ghcid +import Session import Wait import Language.Haskell.Ghcid.Util @@ -40,8 +41,8 @@ -- otherwise GHC warns about .ghci being accessible by others try_ $ system "chmod og-w . .ghci" - withWaiterPoll $ \waiter -> bracket ( - forkIO $ runGhcid waiter [] "ghci" [] Nothing (return (100, 50)) False $ \msg -> + withSession $ \session -> withWaiterPoll $ \waiter -> bracket ( + forkIO $ runGhcid session waiter [] "ghci" [] Nothing (return (100, 50)) False $ \msg -> unless (isLoading $ map snd msg) $ putMVarNow ref $ map snd msg ) killThread $ \_ -> do require requireAllGood diff --git a/src/Wait.hs b/src/Wait.hs --- a/src/Wait.hs +++ b/src/Wait.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +-- | 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 @@ -32,8 +34,16 @@ f $ WaiterNotify manager mvar var --- | Return a message about why you are continuing (usually a file name). --- Reports any changes between the first +-- | 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 :: Waiter -> IO ([FilePath] -> IO [String]) waitFiles waiter = do base <- getCurrentTime