diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for ghcid (* = breaking change) +0.8.2, released 2020-03-08 + #302, --target option for specifying targets for cabal repl + #300, restart on file changes detected by --restart=dir/ 0.8.1, released 2020-01-09 #293, passing --allow-eval should disable -fno-code by default #291, try and be more robust to mucking with the console diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -58,8 +58,12 @@ ### 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 a "real" IDE see [Ghcide](https://github.com/digital-asset/ghcide). +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. Other points in the design space include: +* [ghcide](https://github.com/digital-asset/ghcide) - a real IDE in your editor. +* [reflex-ghci](https://github.com/reflex-frp/reflex-ghci) - like Ghcid but with more terminal UI features. +* [reflex-ghcide](https://github.com/mpickering/reflex-ghcide) - a full IDE in the terminal. + #### 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. @@ -91,3 +95,7 @@ #### How do I run pass command arguments with --test? `ghcid ... --test Main.main --setup ":set args myargs"` + +#### Why do I get "addWatch: resource exhausted (No space left on device)" 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` diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: ghcid -version: 0.8.1 +version: 0.8.2 license: BSD3 license-file: LICENSE category: Development @@ -30,7 +30,7 @@ filepath, time >= 1.5, directory >= 1.2, - extra >= 1.6.6, + extra >= 1.6.20, process >= 1.1, ansi-terminal, cmdargs >= 0.10 @@ -56,7 +56,7 @@ directory >= 1.2, containers, fsnotify, - extra >= 1.6.6, + extra >= 1.6.20, process >= 1.1, cmdargs >= 0.10, ansi-terminal, diff --git a/src/Ghcid.hs b/src/Ghcid.hs --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -65,6 +65,7 @@ ,color :: ColorMode ,setup :: [String] ,allow_eval :: Bool + ,target :: Maybe String } deriving (Data,Typeable,Show) @@ -103,6 +104,7 @@ ,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 = Nothing &= typ "TARGET" &= help "Cabal target to build (e.g. lib:foo)" } &= verbosity &= program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version) @@ -132,21 +134,21 @@ -} autoOptions :: Options -> IO Options autoOptions o@Options{..} - | command /= "" = return $ f [command] [] + | 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 $ return Nothing) $ do + let findStack dir = flip catchIOError (const $ pure Nothing) $ do let yaml = dir "stack.yaml" b <- doesFileExist yaml &&^ doesDirectoryExist (dir ".stack-work") - return $ if b then Just yaml else Nothing + pure $ if b then Just yaml else Nothing stack <- firstJustM findStack [".",".."] -- stack file might be parent, see #62 let cabal = map (curdir ) $ filter ((==) ".cabal" . takeExtension) files let opts = ["-fno-code" | null test && null run && not allow_eval] ++ ghciFlagsRequired ++ ghciFlagsUseful - return $ case () of + pure $ case () of _ | Just stack <- stack -> let flags = if null arguments then "stack ghci --test --bench" : @@ -156,7 +158,12 @@ "stack exec --test --bench -- ghci" : opts in f flags $ stack:cabal | ".ghci" `elem` files -> f ("ghci":opts) [curdir ".ghci"] - | cabal /= [] -> f (if null arguments then "cabal repl":map ("--ghc-options=" ++) opts else "cabal exec -- ghci":opts) cabal + | cabal /= [] -> + let useCabal = + [ "cabal", "repl" ] ++ maybeToList target + ++ map ("--ghc-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} @@ -208,32 +215,32 @@ outStrLn $ "%VERSION: " ++ showVersion version withCurrentDirectory (directory opts) $ do opts <- autoOptions opts - opts <- return $ opts{restart = nubOrd $ (origDir ".ghcid") : restart opts, reload = nubOrd $ reload 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 <- return $ case (width opts, height opts) of - (Just w, Just h) -> return $ TermSize w (noHeight $ Just h) WrapHard + 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 - return $ TermSize + 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 -> return True - Never -> return False + 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 - return $ if useStyle then id else map unescape + pure $ if useStyle then id else map unescape - clear <- return $ + clear <- pure $ if clear opts then (clearScreen *>) else id @@ -248,7 +255,7 @@ where termSize = do x <- Term.size - return $ case x of + pure $ case x of Nothing -> TermSize 80 (Just 8) WrapHard Just t -> TermSize (Term.width t) (Just $ Term.height t) WrapSoft @@ -259,7 +266,9 @@ data Continue = Continue --- If we return successfully, we restart the whole process +data ReloadMode = Reload | Restart deriving (Show, Ord, Eq) + +-- If we pure 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 @@ -267,16 +276,16 @@ let outputFill :: String -> Maybe (Int, [Load]) -> [EvalResult] -> [String] -> IO () outputFill currTime load evals msg = do - load <- return $ case load of + 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 -> return (wrap msg, wrap load, []) + Nothing -> pure (wrap msg, wrap load, []) Just termHeight -> do - (termHeight, msg) <- return $ takeRemainder termHeight $ wrap msg + (termHeight, msg) <- pure $ takeRemainder termHeight $ wrap msg (termHeight, load) <- let takeRemainder' = if reverse_errors @@ -284,8 +293,8 @@ -- the top instead of the bottom of the load fmap reverse . takeRemainder termHeight . reverse else takeRemainder termHeight - in return $ takeRemainder' $ wrap load - return (msg, load, replicate 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 [] = [] @@ -308,15 +317,20 @@ putStrLn $ "\nNo files loaded, GHCi is not working properly.\nCommand: " ++ command exitFailure - restart <- return $ nubOrd $ restart ++ [x | LoadConfig x <- messages] + 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 return project else takeFileName <$> getCurrentDirectory + project <- if project /= "" then pure project else takeFileName <$> getCurrentDirectory -- fire, given a waiter, the messages/loaded/touched - let fire nextWait (messages, loaded, touched) = do + 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 @@ -327,7 +341,7 @@ 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 <- return $ + test <- pure $ if null test || hasErrors then Nothing else Just $ intercalate "\n" test @@ -350,7 +364,7 @@ errTimes <- sequence [(x,) <$> getModTime x | x <- nubOrd $ map loadFile msgError] let f x = lookup (loadFile x) errTimes moduleSorted = sortOn (Down . f) msgError ++ msgWarn - return $ (if reverse_errors then reverse else id) moduleSorted + pure $ (if reverse_errors then reverse else id) moduleSorted outputFill currTime (Just (loadedCount, ordMessages)) evals [test_message | isJust test] forM_ outputfile $ \file -> @@ -378,19 +392,30 @@ (exitcode, stdout, stderr) <- readCreateProcessWithExitCode (shell . unwords $ lintcmd : map escape touched) "" unless (exitcode == ExitSuccess) $ outStrLn (stdout ++ stderr) - reason <- nextWait $ restart ++ reload ++ loaded - whenLoud $ outStrLn $ "%RELOADING: " ++ unwords reason - restartTimes2 <- mapM getModTime restart - let restartChanged = [s | (False, s) <- zip (zipWith (==) restartTimes restartTimes2) restart] + 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 - if not $ null restartChanged then do - -- exit cleanly, since the whole thing is wrapped in a forever - unless no_status $ outputFill currTime Nothing evals $ "Restarting..." : map (" " ++) restartChanged - return Continue - else do - unless no_status $ outputFill currTime Nothing evals $ "Reloading..." : map (" " ++) reason + 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) 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 @@ -92,26 +92,26 @@ -- e.g. https://github.com/ndmitchell/ghcid/issues/291 writeInp $ "\nINTERNAL_GHCID.putStrLn " ++ showStr msg ++ "\n" ++ "INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ showStr msg - return $ isInfixOf msg + pure $ isInfixOf msg let syncFresh = do - modifyVar_ syncCount $ return . succ + modifyVar_ syncCount $ pure . succ syncReplay - -- Consume from a stream until EOF (return Nothing) or some predicate returns Just + -- Consume from a stream until EOF (pure Nothing) or some predicate returns Just let consume :: Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a) consume name finish = do let h = if name == Stdout then out else err flip fix Nothing $ \rec oldMsg -> do el <- tryBool isEOFError $ hGetLine h case el of - Left _ -> return $ Left oldMsg + Left _ -> pure $ Left oldMsg Right l -> do whenLoud $ outStrLn $ "%" ++ upper (show name) ++ ": " ++ l let msg = removePrefix l res <- finish msg case res of Nothing -> rec $ Just msg - Just a -> return $ Right a + Just a -> pure $ Right a let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a) consume2 msg finish = do @@ -125,7 +125,7 @@ ShellCommand cmd -> UnexpectedExit cmd msg err RawCommand exe args -> UnexpectedExit (unwords (exe:args)) msg err case (res1, res2) of - (Right v1, Right v2) -> return (v1, v2) + (Right v1, Right v2) -> pure (v1, v2) (_, Left err) -> raise msg err (_, Right _) -> raise msg Nothing @@ -137,27 +137,27 @@ isRunning <- newLock let ghciExec command echo = do - withLock isInterrupting $ return () + withLock isInterrupting $ pure () res <- withLockTry isRunning $ do writeInp command stop <- syncFresh void $ consume2 command $ \strm s -> - if stop s then return $ Just () else do echo strm s; return Nothing + if stop s then pure $ Just () else do echo strm s; pure Nothing when (isNothing res) $ fail "Ghcid.exec, computation is already running, must be used single-threaded" let ghciInterrupt = withLock isInterrupting $ - whenM (fmap isNothing $ withLockTry isRunning $ return ()) $ do + whenM (fmap isNothing $ withLockTry isRunning $ pure ()) $ 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 () + withLock isRunning $ pure () -- 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 + void $ consume2 "Interrupt" $ \_ s -> pure $ if stop s then Just () else Nothing ghciUnique <- newUnique let ghci = Ghci{..} @@ -169,10 +169,10 @@ consume2 "" $ \strm s -> do stop <- readIORef sync if stop s then - return $ Just () + pure $ 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 + 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 " @@ -190,13 +190,13 @@ writeInp $ ":set " ++ flag writeIORef sync =<< syncFresh echo0 strm s - return Nothing + pure Nothing r1 <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout) -- see #132, if hide-source-paths was turned on the modules didn't get printed out properly -- so try a showModules to capture the information again - r2 <- if any isLoading r1 then return [] else map (uncurry Loading) <$> showModules ghci + r2 <- if any isLoading r1 then pure [] else map (uncurry Loading) <$> showModules ghci execStream ghci "" echo0 - return (ghci, r1 ++ r2) + pure (ghci, r1 ++ r2) -- | Start GHCi by running the given shell command, a helper around 'startGhciProcess'. @@ -239,7 +239,7 @@ -- | Send a command, get lines of result. Must be called single-threaded. exec :: Ghci -> String -> IO [String] -exec ghci cmd = execBuffer ghci cmd $ \_ _ -> return () +exec ghci cmd = execBuffer ghci cmd $ \_ _ -> pure () -- | List the modules currently loaded, with module name and source file. showModules :: Ghci -> IO [(String,FilePath)] @@ -257,7 +257,7 @@ quit :: Ghci -> IO () quit ghci = do interrupt ghci - handle (\UnexpectedExit{} -> return ()) $ void $ exec ghci ":quit" + handle (\UnexpectedExit{} -> pure ()) $ void $ exec ghci ":quit" -- Be aware that waitForProcess has a race condition, see https://github.com/haskell/process/issues/46. -- Therefore just ignore the exception anyway, its probably already terminated. ignored $ void $ waitForProcess $ process ghci diff --git a/src/Language/Haskell/Ghcid/Escape.hs b/src/Language/Haskell/Ghcid/Escape.hs --- a/src/Language/Haskell/Ghcid/Escape.hs +++ b/src/Language/Haskell/Ghcid/Escape.hs @@ -32,7 +32,7 @@ explode = unfoldr unesc implode :: [Either Esc Char] -> Esc -implode = Esc . concatMap (either fromEsc return) +implode = Esc . concatMap (either fromEsc pure) unescape :: String -> String unescape = unescapeE . Esc @@ -52,7 +52,7 @@ stripInfixE needle haystack | Just rest <- stripPrefixE needle haystack = Just (Esc [], rest) stripInfixE needle e = case unesc e of Nothing -> Nothing - Just (x,xs) -> first (app $ fromEither $ fmap (Esc . return) x) <$> stripInfixE needle xs + Just (x,xs) -> first (app $ fromEither $ fmap (Esc . pure) x) <$> stripInfixE needle xs spanE, breakE :: (Char -> Bool) -> Esc -> (Esc, Esc) 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 @@ -102,7 +102,7 @@ x <- lit "," x (c,x) <- digit x x <- lit ")" x - return ((l,c),x) + pure ((l,c),x) -- After the file location, message bodies are indented (perhaps prefixed by a line number) 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 @@ -44,9 +44,9 @@ terminalTopmost = do wnd <- getConsoleWindow setWindowPos wnd hWND_TOPMOST 0 0 0 0 (sWP_NOMOVE .|. sWP_NOSIZE) - return () + pure () #else -terminalTopmost = return () +terminalTopmost = pure () #endif @@ -56,7 +56,7 @@ setWindowIcon :: WindowIcon -> IO () #if defined(mingw32_HOST_OS) setWindowIcon x = do - ico <- return $ case x of + ico <- pure $ case x of IconOK -> iDI_ASTERISK IconWarning -> iDI_EXCLAMATION IconError -> iDI_HAND @@ -65,9 +65,9 @@ -- 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 - return () + pure () #else -setWindowIcon _ = return () +setWindowIcon _ = pure () #endif @@ -81,7 +81,7 @@ act `finally` do sendMessage wnd wM_SETICON iCON_BIG icoBig sendMessage wnd wM_SETICON iCON_SMALL icoSmall - return () + 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 @@ -92,7 +92,7 @@ getModTime :: FilePath -> IO (Maybe UTCTime) getModTime file = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) - (\_ -> return Nothing) + (\_ -> pure Nothing) (Just <$> getModificationTime file) -- | Returns both the amount left (could have been taken more) and the list @@ -106,7 +106,7 @@ -- | Get the smallest difference that can be reported by two modification times getModTimeResolution :: IO Seconds -getModTimeResolution = return getModTimeResolutionCache +getModTimeResolution = pure getModTimeResolutionCache {-# NOINLINE getModTimeResolutionCache #-} -- Cache the result so only computed once per run @@ -122,11 +122,11 @@ flip loopM 0 $ \j -> do writeFile file $ show (i,j) t2 <- getModificationTime file - return $ if t1 == t2 then Left $ j+1 else Right () + pure $ if t1 == t2 then Left $ j+1 else Right () -- GHC 7.6 and below only have 1 sec resolution timestamps - mtime <- return $ if compilerVersion < makeVersion [7,8] then max mtime 1 else mtime + mtime <- pure $ if compilerVersion < makeVersion [7,8] then max mtime 1 else mtime 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 - return $ mtime + min 0.1 mtime + pure $ mtime + min 0.1 mtime diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -58,7 +58,7 @@ let allowEval = False f Session{..} `finally` do debugShutdown "Start finally" - modifyVar_ running $ const $ return False + modifyVar_ running $ const $ pure False whenJustM (readIORef ghci) $ \v -> do writeIORef ghci Nothing debugShutdown "Calling kill" @@ -91,7 +91,7 @@ -- 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 $ return False + modifyVar_ running $ const $ pure False writeIORef command $ Just (cmd, setup) -- cleanup any old instances @@ -104,7 +104,7 @@ (v, messages) <- mask $ \unmask -> do (v, messages) <- unmask $ startGhci cmd Nothing $ const outStrLn writeIORef ghci $ Just v - return (v, messages) + pure (v, messages) -- do whatever preparation was requested exec v $ unlines setup @@ -112,7 +112,7 @@ -- deal with current directory (dir, _) <- showPaths v writeIORef curdir dir - messages <- return $ qualify dir messages + messages <- pure $ qualify dir messages let loaded = loadedModules messages evals <- performEvals v allowEval loaded @@ -126,9 +126,9 @@ throwTo withThread $ ErrorCall $ "Command \"" ++ cmd ++ "\" exited unexpectedly with " ++ show code -- handle what the process returned - messages <- return $ mapMaybe tidyMessage messages + messages <- pure $ mapMaybe tidyMessage messages writeIORef warnings $ getWarnings messages - return (messages ++ evals, loaded) + pure (messages ++ evals, loaded) getWarnings :: [Load] -> [Load] @@ -143,7 +143,7 @@ performEvals :: Ghci -> Bool -> [FilePath] -> IO [Load] -performEvals _ False _ = return [] +performEvals _ False _ = pure [] performEvals ghci True reloaded = do cmds <- mapM getCommands reloaded fmap join $ forM cmds $ \(file, cmds') -> @@ -151,13 +151,13 @@ ref <- newIORef [] execStream ghci (unwords $ lines cmd) $ \_ resp -> modifyIORef ref (resp :) resp <- unlines . reverse <$> readIORef ref - return $ Eval $ EvalResult file (num, 1) cmd resp + pure $ Eval $ EvalResult file (num, 1) cmd resp getCommands :: FilePath -> IO (FilePath, [(Int, String)]) getCommands fp = do ls <- readFileUTF8' fp - return (fp, splitCommands $ zipFrom 1 $ lines ls) + pure (fp, splitCommands $ zipFrom 1 $ lines ls) splitCommands :: [(Int, String)] -> [(Int, String)] splitCommands [] = [] @@ -182,8 +182,8 @@ sessionReload :: Session -> IO ([Load], [FilePath], [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 + 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 @@ -202,10 +202,10 @@ -- 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 + messages <- pure $ messages ++ filter validWarn warn writeIORef warnings $ getWarnings messages - return (messages ++ evals, nubOrd (loaded ++ reloaded), reloaded) + pure (messages ++ evals, nubOrd (loaded ++ reloaded), reloaded) -- | Run an exec operation asynchronously. Should not be a @:reload@ or similar. @@ -215,14 +215,14 @@ sessionExecAsync Session{..} cmd done = do Just ghci <- readIORef ghci stderr <- newIORef "" - modifyVar_ running $ const $ return True + modifyVar_ running $ const $ pure True caller <- myThreadId - void $ flip forkFinally (either (throwTo caller) (const $ return ())) $ do + 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 -> return (False, b) + old <- modifyVar running $ \b -> pure (False, b) -- don't fire Done if someone interrupted us stderr <- readIORef stderr when old $ done stderr diff --git a/src/Test/Ghcid.hs b/src/Test/Ghcid.hs --- a/src/Test/Ghcid.hs +++ b/src/Test/Ghcid.hs @@ -77,10 +77,10 @@ res <- bracket (flip forkFinally (const $ signalBarrier done ()) $ withArgs (["--no-title","--no-status"]++args) $ - mainWithTerminal (return $ TermSize 100 (Just 50) WrapHard) output) + mainWithTerminal (pure $ TermSize 100 (Just 50) WrapHard) output) killThread $ \_ -> script require waitBarrier done - return res + pure res -- | Since different versions of GHCi give different messages, we only try to find what @@ -90,7 +90,7 @@ -- 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) (map simple want) @? + all ((`isInfixOf` got2) . simple) want @? "Expected " ++ show want ++ ", got " ++ show got diff --git a/src/Wait.hs b/src/Wait.hs --- a/src/Wait.hs +++ b/src/Wait.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | Use 'withWaiterPoll' or 'withWaiterNotify' to create a 'Waiter' object, -- then access it (single-threaded) by using 'waitFiles'. @@ -20,8 +21,9 @@ import Language.Haskell.Ghcid.Util -data Waiter = WaiterPoll Seconds - | WaiterNotify WatchManager (MVar ()) (Var (Map.Map FilePath StopListening)) +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 @@ -41,7 +43,7 @@ (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir recurse <- filterM test dirs rest <- concatMapM (listContentsInside test) recurse - return $ addTrailingPathSeparator dir : files ++ rest + pure $ addTrailingPathSeparator dir : files ++ rest -- | Given the pattern: -- @@ -52,20 +54,26 @@ -- 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]) +-- pures 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 - return $ \files -> handle (\(e :: IOError) -> do sleep 1.0; return ["Error when waiting, if this happens repeatedly, raise a ghcid bug.",show e]) $ do - whenLoud $ outStrLn $ "%WAITING: " ++ unwords files - -- As listContentsInside returns directories, we are waiting on them explicitly and so + 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 pures 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 <- fmap concat $ forM files $ \file -> - ifM (doesDirectoryExist file) (listContentsInside (return . not . isPrefixOf "." . takeFileName) file) (return [file]) + files <- concatForM files $ \(file, a) -> + ifM (doesDirectoryExist file) (fmap (,a) <$> listContentsInside (pure . not . isPrefixOf "." . takeFileName) file) (pure [(file, a)]) case waiter of - WaiterPoll t -> return () + WaiterPoll t -> pure () WaiterNotify manager kick mp -> do - dirs <- fmap Set.fromList $ mapM canonicalizePathSafe $ nubOrd $ map takeDirectory files + 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 @@ -73,40 +81,41 @@ can <- watchDir manager (fromString dir) (const True) $ \event -> do whenLoud $ outStrLn $ "%NOTIFY: " ++ show event void $ tryPutMVar kick () - return (dir, can) + pure (dir, can) let mp2 = keep `Map.union` Map.fromList new whenLoud $ outStrLn $ "%WAITING: " ++ unwords (Map.keys mp2) - return mp2 + pure mp2 void $ tryTakeMVar kick - new <- mapM getModTime files + new <- mapM (getModTime . fst) files case [x | (x,Just t) <- zip files new, t > base] of - [] -> recheck files new - xs -> return xs - where - recheck files old = do + [] -> 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 files + 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] - when (disappeared /= []) $ do + 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 disappeared - -- at most 20 iterations, but stop as soon as the file returns + 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 pures void $ flip firstJustM (replicate 20 ()) $ \_ -> do sleep 0.05 - new <- mapM getModTime files - return $ if null [x | (x, Just _, Nothing) <- zip3 files old new] then Just () else Nothing - return xs + 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) -> return x +canonicalizePathSafe x = canonicalizePath x `catch` \(_ :: IOError) -> pure x