diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,14 @@ -Changelog for GHCiD +Changelog for ghcid +0.6.2 + #63, detect test failures and update the titlebar/icon + #66, add --warnings to run tests even in there are warnings + #62, find stack.yaml in the parent directory + Make --verbose echo all things sent to stdin + #57, support wrappers that access stdin first (e.g. stack) + #67, make --reload/--restart recurse through directories + #61, deal with drive letters in files (for stack on Windows) + #58, improve the --help message 0.6.1 Add --reload to add files that reload, but do not restart #56, allow --restart to take directories diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,3 +35,4 @@ * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). * _If I delete a file and put it back it gets stuck._ Yes, that's a [bug in GHCi](https://ghc.haskell.org/trac/ghc/ticket/9648). If you see GHCi getting confused just kill `ghcid` and start it again. +* _I want to run arbitrary commands when arbitrary files change._ This project reloads `ghci` when files loaded by `ghci` change. If you want a more general mechanism something like [Steel Overseer](https://github.com/steeloverseer/steeloverseer) will probably work better. 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.6.1 +version: 0.6.2 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 @@ -5,6 +5,7 @@ module Ghcid(main, runGhcid) where import Control.Exception +import System.IO.Error import Control.Monad.Extra import Data.List.Extra import Data.Maybe @@ -18,6 +19,7 @@ import System.Exit import System.FilePath import System.IO +import System.IO.Unsafe import Paths_ghcid import Language.Haskell.Ghcid @@ -32,6 +34,7 @@ {command :: String ,arguments :: [String] ,test :: Maybe String + ,warnings :: Bool ,height :: Maybe Int ,width :: Maybe Int ,topmost :: Bool @@ -48,12 +51,13 @@ {command = "" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)" ,arguments = [] &= args &= typ "MODULE" ,test = Nothing &= name "T" &= typ "EXPR" &= help "Command to run after successful loading" + ,warnings = False &= name "W" &= help "Allow tests to run even with warnings" ,height = Nothing &= help "Number of lines to use (defaults to console height)" - ,width = Nothing &= help "Number of columns to use (defaults to console width)" + ,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" - ,restart = [] &= typFile &= help "Restart the command if any of these files change (defaults to .ghci or .cabal)" - ,reload = [] &= typFile &= help "Reload if any of these files change (defaults to none)" + ,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" ,outputfile = [] &= typFile &= name "o" &= help "File to write the full output to" } &= verbosity &= @@ -88,10 +92,15 @@ | command /= "" = return $ f [command] [] | otherwise = do files <- getDirectoryContents "." + + -- use unsafePerformIO to get nicer pattern matching for logic (read-only operations) + let isStack dir = unsafePerformIO $ flip catchIOError (const $ return False) $ + doesFileExist (dir "stack.yaml") &&^ doesDirectoryExist (dir ".stack-work") + let cabal = filter ((==) ".cabal" . takeExtension) files let opts = ["-fno-code" | isNothing test] return $ case () of - _ | "stack.yaml" `elem` files, ".stack-work" `elem` files -> + _ | cabal /= [], isStack "." || isStack ".." -> -- stack file might be parent, see #62 let flags = if null arguments then "stack ghci --test" : ["--no-load" | ".ghci" `elem` files] ++ @@ -128,7 +137,7 @@ return (f width 80 (pred . fst), f height 8 snd) withWaiterNotify $ \waiter -> handle (\(UnexpectedExit cmd _) -> putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly") $ - runGhcid session waiter (nubOrd restart) (nubOrd reload) command outputfile test height (not notitle) $ \xs -> do + runGhcid session waiter (nubOrd restart) (nubOrd reload) command outputfile test warnings height (not notitle) $ \xs -> do outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity] putStr $ concatMap ((:) '\n' . snd) x @@ -139,8 +148,8 @@ data Style = Plain | Bold deriving Eq -runGhcid :: Session -> Waiter -> [FilePath] -> [FilePath] -> String -> [FilePath] -> Maybe String -> IO (Int,Int) -> Bool -> ([(Style,String)] -> IO ()) -> IO () -runGhcid session waiter restart reload command outputfiles test size titles output = do +runGhcid :: Session -> Waiter -> [FilePath] -> [FilePath] -> String -> [FilePath] -> Maybe String -> Bool -> IO (Int,Int) -> Bool -> ([(Style,String)] -> IO ()) -> IO () +runGhcid session waiter restart reload command outputfiles test warnings size titles output = do let outputFill :: Maybe (Int, [Load]) -> [String] -> IO () outputFill load msg = do (width, height) <- size @@ -162,7 +171,7 @@ let (countErrors, countWarnings) = both sum $ unzip [if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []] - test <- return $ if countErrors == 0 && countWarnings == 0 then test else Nothing + test <- return $ if countErrors == 0 && (warnings || countWarnings == 0) then test else Nothing when titles $ setWindowIcon $ if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK @@ -182,9 +191,13 @@ exitFailure whenJust test $ \t -> do whenLoud $ outStrLn $ "%TESTING: " ++ t - sessionExecAsync session t $ do + sessionExecAsync session t $ \stderr -> do whenLoud $ outStrLn "%TESTING: Completed" - updateTitle "(test done)" + if "*** Exception: " `isPrefixOf` stderr then do + updateTitle "(test failed)" + setWindowIcon IconError + else + updateTitle "(test done)" reason <- nextWait $ restart ++ reload ++ loaded outputFill Nothing $ "Reloading..." : map (" " ++) reason @@ -193,7 +206,7 @@ nextWait <- waitFiles waiter fire nextWait =<< sessionReload session else do - runGhcid session waiter restart reload command outputfiles test size titles output + runGhcid session waiter restart reload command outputfiles test warnings size titles output nextWait <- waitFiles waiter (messages, loaded) <- sessionStart session command 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 @@ -52,13 +52,18 @@ hSetBuffering out LineBuffering hSetBuffering err LineBuffering hSetBuffering inp LineBuffering + let writeInp x = do + whenLoud $ outStrLn $ "%STDIN: " ++ x + hPutStrLn inp x + -- Some programs (e.g. stack) might use stdin before starting ghci (see #57) + -- Send them an empty line + hPutStrLn inp "" + -- 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 -- 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 @@ -66,7 +71,7 @@ let syncReplay = do i <- readVar syncCount let msg = "#~GHCID-FINISH-" ++ show i ++ "~#" - hPutStrLn inp $ "Prelude.putStrLn " ++ show msg ++ "\nPrelude.error " ++ show msg + writeInp $ "Prelude.putStrLn " ++ show msg ++ "\nPrelude.error " ++ show msg return $ isInfixOf msg let syncFresh = do modifyVar_ syncCount $ return . succ @@ -96,7 +101,6 @@ Nothing -> throwIO $ UnexpectedExit cmd msg Just v -> return v - -- held while interrupting, and briefly held when starting an exec -- ensures exec values queue up behind an ongoing interrupt and no two interrupts run at once isInterrupting <- newLock @@ -107,8 +111,7 @@ let ghciExec command echo = do withLock isInterrupting $ return () res <- withLockTry isRunning $ do - whenLoud $ outStrLn $ "%GHCINP: " ++ command - hPutStrLn inp command + writeInp command stop <- syncFresh void $ consume2 command $ \strm s -> if stop s then return $ Just () else do echo strm s; return Nothing @@ -129,7 +132,31 @@ void $ consume2 "Interrupt" $ \_ s -> return $ if stop s then Just () else Nothing let ghci = Ghci{..} - r <- parseLoad <$> execBuffer ghci "" echo0 + + -- Now wait for 'GHCi, version' to appear before sending anything real, required for #57 + stdout <- newIORef [] + stderr <- newIORef [] + sync <- newIORef $ const False + consume2 "" $ \strm s -> do + stop <- readIORef sync + if stop s then + return $ Just () + else do + -- there may be some initial prompts on stdout before I set the prompt properly + s <- return $ maybe s (removePrefix . snd) $ stripInfix ghcid_prefix s + whenLoud $ outStrLn $ "%STDOUT2: " ++ s + modifyIORef (if strm == Stdout then stdout else stderr) (s:) + when ("GHCi, version " `isPrefixOf` s) $ do + -- the thing before me may have done its own Haskell compiling + writeIORef stdout [] + writeIORef stderr [] + writeIORef sync =<< syncFresh + writeInp $ ":set prompt " ++ ghcid_prefix + writeInp ":set -fno-break-on-exception -fno-break-on-error" -- see #43 + echo0 strm s + return Nothing + r <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout) + execStream ghci "" echo0 return (ghci, r) @@ -157,9 +184,9 @@ 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 + execStream ghci cmd $ \strm s -> do + modifyIORef (if strm == Stdout then stdout else stderr) (s:) + echo strm s reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout) -- | Send a command, get lines of result. Must be called single-threaded. 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 @@ -8,6 +8,9 @@ import System.FilePath import Data.Char import Data.List.Extra +import Data.Tuple.Extra +import Control.Applicative +import Prelude import Language.Haskell.Ghcid.Types @@ -31,7 +34,7 @@ f rest f (x:xs) | not $ " " `isPrefixOf` x - , (file,':':rest) <- break (== ':') x + , Just (file,rest) <- breakFileColon x , takeExtension file `elem` [".hs",".lhs"] , (pos,rest2) <- span (\c -> c == ':' || isDigit c) rest , [p1,p2] <- map read $ words $ map (\c -> if c == ':' then ' ' else c) pos @@ -51,3 +54,9 @@ [Message Error m (0,0) [] | m <- nubOrd ms] ++ f rest f (_:xs) = f xs f [] = [] + + +-- A filename, followed by a colon - be careful to handle Windows drive letters, see #61 +breakFileColon :: String -> Maybe (FilePath, String) +breakFileColon (x:':':xs) | isLetter x = first ([x,':']++) <$> stripInfix ":" xs +breakFileColon xs = stripInfix ":" xs diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -111,18 +111,22 @@ -- | 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 () +-- 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 $ return True void $ forkIO $ do - execStream ghci cmd $ \_ msg -> - when (msg /= "*** Exception: ExitSuccess") $ + execStream ghci cmd $ \strm msg -> + when (msg /= "*** Exception: ExitSuccess") $ do + when (strm == Stderr) $ writeIORef stderr msg outStrLn msg old <- modifyVar running $ \b -> return (False, b) -- don't fire Done if someone interrupted us - when old done + stderr <- readIORef stderr + when old $ done stderr -- | Ignore entirely pointless messages and remove unnecessary lines. diff --git a/src/Test/Parser.hs b/src/Test/Parser.hs --- a/src/Test/Parser.hs +++ b/src/Test/Parser.hs @@ -30,7 +30,7 @@ , Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (70,1), loadMessage = ["GHCi.hs:70:1: Parse error: naked expression at top level"]} , Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (72,13), loadMessage = ["GHCi.hs:72:13:"," No instance for (Num ([String] -> [String]))"," arising from the literal `1'"," Possible fix:"," add an instance declaration for (Num ([String] -> [String]))"," In the expression: 1"," In an equation for `parseLoad': parseLoad = 1"]} , Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (81,1), loadMessage = ["GHCi.hs:81:1: Warning: Defined but not used: `foo'"]} - , Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (82,1), loadMessage = ["GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]} + , Message {loadSeverity = Warning, loadFile = "C:\\GHCi.hs", loadFilePos = (82,1), loadMessage = ["C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]} ] ] @@ -46,5 +46,5 @@ , " In the expression: 1" , " In an equation for `parseLoad': parseLoad = 1" , "GHCi.hs:81:1: Warning: Defined but not used: `foo'" - , "GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase + , "C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase ] diff --git a/src/Test/Polling.hs b/src/Test/Polling.hs --- a/src/Test/Polling.hs +++ b/src/Test/Polling.hs @@ -42,7 +42,7 @@ try_ $ system "chmod og-w . .ghci" withSession $ \session -> withWaiterPoll $ \waiter -> bracket ( - forkIO $ runGhcid session waiter [] [] "ghci" [] Nothing (return (100, 50)) False $ \msg -> + forkIO $ runGhcid session waiter [] [] "ghci" [] Nothing False (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 @@ -50,7 +50,7 @@ return $ \files -> handle (\(e :: IOError) -> do sleep 0.1; return [show e]) $ do whenLoud $ outStrLn $ "%WAITING: " ++ unwords files files <- fmap concat $ forM files $ \file -> - ifM (doesDirectoryExist file) (listFiles file) (return [file]) + ifM (doesDirectoryExist file) (listFilesInside (return . not . isPrefixOf "." . takeFileName) file) (return [file]) case waiter of WaiterPoll -> return () WaiterNotify manager kick mp -> do