Improve progress reporting

src/Extract.hs

@@ -2,7 +2,6 @@
 module Extract (Module(..), extract) where
 
 import           Imports hiding (mod, concat)
-import           Control.Exception
 import           Data.List (partition, isSuffixOf)
 
 import           Control.DeepSeq (deepseq, NFData(rnf))

src/Imports.hs

@@ -4,7 +4,9 @@ module Imports (module Imports) where
 import           Prelude as Imports
 import           Data.Monoid as Imports
 import           Data.Maybe as Imports
-import           Control.Monad as Imports
+import           Control.Monad as Imports hiding (forM_)
+import           Control.Exception as Imports
+import           Data.Foldable as Imports (forM_)
 import           Control.Arrow as Imports
 
 import           Data.Char

src/Interpreter.hs

@@ -17,7 +17,6 @@ import           Imports
 
 import           System.Process
 import           System.Directory (getPermissions, executable)
-import           Control.Exception hiding (handle)
 import           GHC.Paths (ghc)
 
 import           Language.Haskell.GhciWrapper

src/Language/Haskell/GhciWrapper.hs

@@ -14,7 +14,6 @@ import           Imports
 import           System.IO hiding (stdin, stdout, stderr)
 import           System.Process
 import           System.Exit
-import           Control.Exception
 import           Data.List (isSuffixOf)
 
 data Config = Config {

src/Runner.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 module Runner (
   runModules
 , Summary(..)
@@ -7,16 +8,15 @@ module Runner (
 , Report
 , ReportState (..)
 , report
-, report_
+, reportTransient
 #endif
 ) where
 
-import           Prelude hiding (putStr, putStrLn, error)
+import           Prelude ()
+import           Imports hiding (putStr, putStrLn, error)
 
-import           Control.Monad hiding (forM_)
 import           Text.Printf (printf)
-import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
-import           Data.Foldable (forM_)
+import           System.IO (hGetBuffering, hSetBuffering, BufferMode(..), hFlush, hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
 
 import           Control.Monad.Trans.State
 import           Control.Monad.IO.Class
@@ -41,7 +41,6 @@ instance Show Summary where
   show (Summary examples tried errors failures) =
     printf "Examples: %d  Tried: %d  Errors: %d  Failures: %d" examples tried errors failures
 
-
 -- | Sum up summaries.
 instance Monoid Summary where
   mempty = Summary 0 0 0 0
@@ -55,9 +54,11 @@ instance Semigroup Summary where
 
 -- | Run all examples from a list of modules.
 runModules :: Bool -> Bool -> Bool -> Interpreter -> [Module [Located DocTest]] -> IO Summary
-runModules fastMode preserveIt verbose repl modules = do
+runModules fastMode preserveIt verbose repl modules = bracket (hGetBuffering stderr) (hSetBuffering stderr) $ \ _ -> do
+  hSetBuffering stderr LineBuffering
+
   isInteractive <- hIsTerminalDevice stderr
-  ReportState _ _ _ s <- (`execStateT` ReportState 0 isInteractive verbose mempty {sExamples = c}) $ do
+  ReportState _ _ s <- (`execStateT` ReportState isInteractive verbose mempty {sExamples = c}) $ do
     forM_ modules $ runModule fastMode preserveIt repl
 
     verboseReport "# Final summary:"
@@ -75,39 +76,27 @@ count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup
 type Report = StateT ReportState IO
 
 data ReportState = ReportState {
-  reportStateCount        :: Int     -- ^ characters on the current line
-, reportStateInteractive  :: Bool    -- ^ should intermediate results be printed?
+  reportStateInteractive  :: Bool    -- ^ should intermediate results be printed?
 , reportStateVerbose      :: Bool
 , reportStateSummary      :: Summary -- ^ test summary
 }
 
 -- | Add output to the report.
 report :: String -> Report ()
-report msg = do
-  overwrite msg
-
-  -- add a newline, this makes the output permanent
-  liftIO $ hPutStrLn stderr ""
-  modify (\st -> st {reportStateCount = 0})
+report = liftIO . hPutStrLn stderr
 
 -- | Add intermediate output to the report.
 --
 -- This will be overwritten by subsequent calls to `report`/`report_`.
 -- Intermediate out may not contain any newlines.
-report_ :: String -> Report ()
-report_ msg = do
-  f <- gets reportStateInteractive
-  when f $ do
-    overwrite msg
-    modify (\st -> st {reportStateCount = length msg})
-
--- | Add output to the report, overwrite any intermediate out.
-overwrite :: String -> Report ()
-overwrite msg = do
-  n <- gets reportStateCount
-  let str | 0 < n     = "\r" ++ msg ++ replicate (n - length msg) ' '
-          | otherwise = msg
-  liftIO (hPutStr stderr str)
+reportTransient :: String -> Report ()
+reportTransient msg = do
+  gets reportStateInteractive >>= \ case
+    False -> pass
+    True -> liftIO $ do
+      hPutStr stderr msg
+      hFlush stderr
+      hPutStr stderr $ '\r' : (replicate (length msg) ' ') ++ "\r"
 
 -- | Run all examples from given module.
 runModule :: Bool -> Bool -> Interpreter -> Module [Located DocTest] -> Report ()
@@ -177,13 +166,13 @@ verboseReport xs = do
 
 updateSummary :: Summary -> Report ()
 updateSummary summary = do
-  ReportState n f v s <- get
-  put (ReportState n f v $ s `mappend` summary)
+  ReportState f v s <- get
+  put (ReportState f v $ s `mappend` summary)
 
 reportProgress :: Report ()
 reportProgress = do
   verbose <- gets reportStateVerbose
-  when (not verbose) $ gets (show . reportStateSummary) >>= report_
+  when (not verbose) $ gets (show . reportStateSummary) >>= reportTransient
 
 -- | Run given test group.
 --
@@ -224,6 +213,7 @@ runExampleGroup :: Bool -> Interpreter -> [Located Interaction] -> Report ()
 runExampleGroup preserveIt repl = go
   where
     go ((Located loc (expression, expected)) : xs) = do
+      reportProgress
       reportStart loc expression "example"
       r <- fmap lines <$> liftIO (safeEvalWith preserveIt repl expression)
       case r of

test/Language/Haskell/GhciWrapperSpec.hs

@@ -6,7 +6,6 @@ import           Imports
 import           Test.Hspec
 import           System.IO.Silently
 
-import           Control.Exception
 import           Data.List
 
 import           Language.Haskell.GhciWrapper (Interpreter, Config(..), defaultConfig)

test/MainSpec.hs

@@ -7,7 +7,6 @@ import           Imports
 import           Test.Hspec
 import           Test.HUnit (assertEqual, Assertion)
 
-import           Control.Exception
 import           System.Directory (getCurrentDirectory, setCurrentDirectory)
 import           System.FilePath
 import           Run hiding (doctest)

test/RunnerSpec.hs

@@ -14,11 +14,11 @@ main :: IO ()
 main = hspec spec
 
 capture :: Report a -> IO String
-capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True False mempty)
+capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState True False mempty)
 
 -- like capture, but with interactivity set to False
 capture_ :: Report a -> IO String
-capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False False mempty)
+capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState False False mempty)
 
 spec :: Spec
 spec = do
@@ -34,15 +34,15 @@ spec = do
 
       it "overwrites any intermediate output" $ do
         capture $ do
-          report_ "foo"
+          reportTransient "foo"
           report  "bar"
-        `shouldReturn` "foo\rbar\n"
+        `shouldReturn` "foo\r   \rbar\n"
 
       it "blank out intermediate output if necessary" $ do
         capture $ do
-          report_ "foobar"
+          reportTransient "foobar"
           report  "baz"
-        `shouldReturn` "foobar\rbaz   \n"
+        `shouldReturn` "foobar\r      \rbaz\n"
 
     context "when mode is non-interactive" $ do
       it "writes to stderr" $ do
@@ -55,35 +55,35 @@ spec = do
     context "when mode is interactive" $ do
       it "writes intermediate output to stderr" $ do
         capture $ do
-          report_ "foobar"
-        `shouldReturn` "foobar"
+          reportTransient "foobar"
+        `shouldReturn` "foobar\r      \r"
 
       it "overwrites any intermediate output" $ do
         capture $ do
-          report_ "foo"
-          report_ "bar"
-        `shouldReturn` "foo\rbar"
+          reportTransient "foo"
+          reportTransient "bar"
+        `shouldReturn` "foo\r   \rbar\r   \r"
 
       it "blank out intermediate output if necessary" $ do
         capture $ do
-          report_ "foobar"
-          report_  "baz"
-        `shouldReturn` "foobar\rbaz   "
+          reportTransient "foobar"
+          reportTransient  "baz"
+        `shouldReturn` "foobar\r      \rbaz\r   \r"
 
     context "when mode is non-interactive" $ do
       it "is ignored" $ do
         capture_ $ do
-          report_ "foobar"
+          reportTransient "foobar"
         `shouldReturn` ""
 
       it "does not influence a subsequent call to `report`" $ do
         capture_ $ do
-          report_ "foo"
+          reportTransient "foo"
           report  "bar"
         `shouldReturn` "bar\n"
 
       it "does not require `report` to blank out any intermediate output" $ do
         capture_ $ do
-          report_ "foobar"
+          reportTransient "foobar"
           report  "baz"
         `shouldReturn` "baz\n"