diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,6 @@ +Changes in 0.22.10 + - Make progress reporting more robust + Changes in 0.22.9 - Use `-fprint-error-index-links=never` for GHC `>=9.10` diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: doctest -version: 0.22.9 +version: 0.22.10 synopsis: Test interactive Haskell examples description: `doctest` is a tool that checks [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) and [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856) diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/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)) diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -1,15 +1,26 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} 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 import System.Exit import System.Process + +#if __GLASGOW_HASKELL__ >= 804 +import Data.Functor as Imports ((<&>)) +#else +infixl 1 <&> +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap +#endif pass :: Monad m => m () pass = return () diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -17,7 +17,6 @@ import System.Process import System.Directory (getPermissions, executable) -import Control.Exception hiding (handle) import GHC.Paths (ghc) import Language.Haskell.GhciWrapper diff --git a/src/Language/Haskell/GhciWrapper.hs b/src/Language/Haskell/GhciWrapper.hs --- a/src/Language/Haskell/GhciWrapper.hs +++ b/src/Language/Haskell/GhciWrapper.hs @@ -14,7 +14,6 @@ import System.IO hiding (stdin, stdout, stderr) import System.Process import System.Exit -import Control.Exception import Data.List (isSuffixOf) data Config = Config { diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -9,6 +9,7 @@ , Result , Summary(..) +, formatSummary , isSuccess , evaluateResult , doctestWithResult @@ -154,4 +155,6 @@ runDocTests :: Config -> [Module [Located DocTest]] -> IO Result runDocTests Config{..} modules = do Interpreter.withInterpreter ((<> ghcOptions) <$> repl) $ \ interpreter -> withCP65001 $ do - runModules fastMode preserveIt verbose interpreter modules + let + v = if verbose then Verbose else NonVerbose + runModules fastMode preserveIt v interpreter modules diff --git a/src/Runner.hs b/src/Runner.hs --- a/src/Runner.hs +++ b/src/Runner.hs @@ -1,25 +1,29 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module Runner ( runModules +, Verbose(..) , Summary(..) +, formatSummary #ifdef TEST , Report -, ReportState (..) +, ReportState(..) +, Interactive(..) , 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 hiding (putStr, putStrLn) import Control.Monad.Trans.State import Control.Monad.IO.Class +import Data.IORef import Interpreter (Interpreter) import qualified Interpreter @@ -30,17 +34,18 @@ -- | Summary of a test run. data Summary = Summary { - sExamples :: Int -, sTried :: Int -, sErrors :: Int -, sFailures :: Int + sExamples :: !Int +, sTried :: !Int +, sErrors :: !Int +, sFailures :: !Int } deriving Eq --- | Format a summary. instance Show Summary where - show (Summary examples tried errors failures) = - printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures + show = formatSummary +formatSummary :: Summary -> String +formatSummary (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 @@ -53,72 +58,85 @@ #endif (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) +withLineBuffering :: Handle -> IO c -> IO c +withLineBuffering h action = bracket (hGetBuffering h) (hSetBuffering h) $ \ _ -> do + hSetBuffering h LineBuffering + action + -- | 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 - isInteractive <- hIsTerminalDevice stderr - ReportState _ _ _ s <- (`execStateT` ReportState 0 isInteractive verbose mempty {sExamples = c}) $ do - forM_ modules $ runModule fastMode preserveIt repl +runModules :: Bool -> Bool -> Verbose -> Interpreter -> [Module [Located DocTest]] -> IO Summary +runModules fastMode preserveIt verbose repl modules = withLineBuffering stderr $ do - verboseReport "# Final summary:" - gets (show . reportStateSummary) >>= report + interactive <- hIsTerminalDevice stderr <&> \ case + False -> NonInteractive + True -> Interactive - return s + summary <- newIORef mempty {sExamples = n} + + let + reportFinalResult :: IO () + reportFinalResult = do + final <- readIORef summary + hPutStrLn stderr (formatSummary final) + + run :: IO () + run = flip evalStateT (ReportState interactive verbose summary) $ do + reportProgress + forM_ modules $ runModule fastMode preserveIt repl + verboseReport "# Final summary:" + + run `finally` reportFinalResult + + readIORef summary where - c = (sum . map count) modules + n :: Int + n = sum (map countExpressions modules) --- | Count number of expressions in given module. -count :: Module [Located DocTest] -> Int -count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup +countExpressions :: Module [Located DocTest] -> Int +countExpressions (Module _ setup tests) = sum (map length tests) + maybe 0 length setup --- | A monad for generating test reports. type Report = StateT ReportState IO +data Interactive = NonInteractive | Interactive + +data Verbose = NonVerbose | Verbose + deriving (Eq, Show) + data ReportState = ReportState { - reportStateCount :: Int -- ^ characters on the current line -, reportStateInteractive :: Bool -- ^ should intermediate results be printed? -, reportStateVerbose :: Bool -, reportStateSummary :: Summary -- ^ test summary + reportStateInteractive :: Interactive +, reportStateVerbose :: Verbose +, reportStateSummary :: IORef Summary } +getSummary :: Report Summary +getSummary = gets reportStateSummary >>= liftIO . readIORef + -- | 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 = gets reportStateInteractive >>= \ case + NonInteractive -> pass + Interactive -> 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 () runModule fastMode preserveIt repl (Module module_ setup examples) = do - Summary _ _ e0 f0 <- gets reportStateSummary + Summary _ _ e0 f0 <- getSummary forM_ setup $ runTestGroup preserveIt repl reload - Summary _ _ e1 f1 <- gets reportStateSummary + Summary _ _ e1 f1 <- getSummary -- only run tests, if setup does not produce any errors/failures when (e0 == e1 && f0 == f1) $ @@ -171,19 +189,22 @@ updateSummary (Summary 0 1 0 0) verboseReport :: String -> Report () -verboseReport xs = do - verbose <- gets reportStateVerbose - when verbose $ report xs +verboseReport msg = gets reportStateVerbose >>= \ case + NonVerbose -> pass + Verbose -> report msg updateSummary :: Summary -> Report () updateSummary summary = do - ReportState n f v s <- get - put (ReportState n f v $ s `mappend` summary) + ref <- gets reportStateSummary + liftIO $ modifyIORef' ref $ mappend summary + reportProgress reportProgress :: Report () -reportProgress = do - verbose <- gets reportStateVerbose - when (not verbose) $ gets (show . reportStateSummary) >>= report_ +reportProgress = gets reportStateVerbose >>= \ case + NonVerbose -> do + summary <- getSummary + reportTransient (formatSummary summary) + Verbose -> pass -- | Run given test group. -- @@ -191,9 +212,6 @@ -- can reuse the same 'Interpreter' for several test groups. runTestGroup :: Bool -> Interpreter -> IO () -> [Located DocTest] -> Report () runTestGroup preserveIt repl setup tests = do - - reportProgress - liftIO setup runExampleGroup preserveIt repl examples diff --git a/test/Language/Haskell/GhciWrapperSpec.hs b/test/Language/Haskell/GhciWrapperSpec.hs --- a/test/Language/Haskell/GhciWrapperSpec.hs +++ b/test/Language/Haskell/GhciWrapperSpec.hs @@ -6,7 +6,6 @@ import Test.Hspec import System.IO.Silently -import Control.Exception import Data.List import Language.Haskell.GhciWrapper (Interpreter, Config(..), defaultConfig) diff --git a/test/MainSpec.hs b/test/MainSpec.hs --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -7,7 +7,6 @@ import Test.Hspec import Test.HUnit (assertEqual, Assertion) -import Control.Exception import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.FilePath import Run hiding (doctest) @@ -27,7 +26,7 @@ doctestWithPreserveIt :: HasCallStack => Bool -> FilePath -> [String] -> Summary -> Assertion doctestWithPreserveIt preserveIt workingDir ghcOptions expected = do actual <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctestWithResult defaultConfig {ghcOptions, preserveIt}) - assertEqual label expected actual + assertEqual label (formatSummary expected) (formatSummary actual) where label = workingDir ++ " " ++ show ghcOptions diff --git a/test/RunnerSpec.hs b/test/RunnerSpec.hs --- a/test/RunnerSpec.hs +++ b/test/RunnerSpec.hs @@ -1,89 +1,45 @@ {-# LANGUAGE CPP, OverloadedStrings #-} -module RunnerSpec (main, spec) where +module RunnerSpec (spec) where import Imports import Test.Hspec +import Data.IORef import System.IO -import System.IO.Silently (hCapture) +import System.IO.Silently (hCapture_) import Control.Monad.Trans.State import Runner -main :: IO () -main = hspec spec - -capture :: Report a -> IO String -capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 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 :: Interactive -> Report a -> IO String +capture interactive action = do + ref <- newIORef mempty + hCapture_ [stderr] (evalStateT action (ReportState interactive NonVerbose ref)) spec :: Spec spec = do - describe "report" $ do - context "when mode is interactive" $ do - it "writes to stderr" $ do - capture $ do + capture Interactive $ do report "foobar" `shouldReturn` "foobar\n" - it "overwrites any intermediate output" $ do - capture $ do - report_ "foo" - report "bar" - `shouldReturn` "foo\rbar\n" - - it "blank out intermediate output if necessary" $ do - capture $ do - report_ "foobar" - report "baz" - `shouldReturn` "foobar\rbaz \n" - context "when mode is non-interactive" $ do it "writes to stderr" $ do - capture_ $ do + capture NonInteractive $ do report "foobar" `shouldReturn` "foobar\n" describe "report_" $ do - context "when mode is interactive" $ do - it "writes intermediate output to stderr" $ do - capture $ do - report_ "foobar" - `shouldReturn` "foobar" - - it "overwrites any intermediate output" $ do - capture $ do - report_ "foo" - report_ "bar" - `shouldReturn` "foo\rbar" - - it "blank out intermediate output if necessary" $ do - capture $ do - report_ "foobar" - report_ "baz" - `shouldReturn` "foobar\rbaz " + it "writes transient output to stderr" $ do + capture Interactive $ do + reportTransient "foobar" + `shouldReturn` "foobar\r \r" context "when mode is non-interactive" $ do it "is ignored" $ do - capture_ $ do - report_ "foobar" + capture NonInteractive $ do + reportTransient "foobar" `shouldReturn` "" - - it "does not influence a subsequent call to `report`" $ do - capture_ $ do - report_ "foo" - report "bar" - `shouldReturn` "bar\n" - - it "does not require `report` to blank out any intermediate output" $ do - capture_ $ do - report_ "foobar" - report "baz" - `shouldReturn` "baz\n"