ghcid 0.8.1 → 0.8.2
raw patch · 12 files changed
+162/−117 lines, 12 filesdep ~extraPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: extra
API changes (from Hackage documentation)
Files
- CHANGES.txt +3/−0
- README.md +9/−1
- ghcid.cabal +3/−3
- src/Ghcid.hs +60/−35
- src/Language/Haskell/Ghcid.hs +18/−18
- src/Language/Haskell/Ghcid/Escape.hs +2/−2
- src/Language/Haskell/Ghcid/Parser.hs +1/−1
- src/Language/Haskell/Ghcid/Terminal.hs +6/−6
- src/Language/Haskell/Ghcid/Util.hs +5/−5
- src/Session.hs +16/−16
- src/Test/Ghcid.hs +3/−3
- src/Wait.hs +36/−27
CHANGES.txt view
@@ -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
README.md view
@@ -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`
ghcid.cabal view
@@ -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,
src/Ghcid.hs view
@@ -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 <something>" ,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)
src/Language/Haskell/Ghcid.hs view
@@ -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
src/Language/Haskell/Ghcid/Escape.hs view
@@ -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)
src/Language/Haskell/Ghcid/Parser.hs view
@@ -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)
src/Language/Haskell/Ghcid/Terminal.hs view
@@ -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
src/Language/Haskell/Ghcid/Util.hs view
@@ -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
src/Session.hs view
@@ -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
src/Test/Ghcid.hs view
@@ -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
src/Wait.hs view
@@ -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