diff --git a/src/Imports.hs b/src/Imports.hs index cdbe3db..3531f0b 100644 --- a/src/Imports.hs +++ b/src/Imports.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module Imports (module Imports) where @@ -13,6 +14,14 @@ 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/Run.hs b/src/Run.hs index cab68fc..d963c4f 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -9,6 +9,7 @@ module Run ( , Result , Summary(..) +, formatSummary , isSuccess , evaluateResult , doctestWithResult @@ -154,4 +155,6 @@ doctestWithResult config = do 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 index 285bfe7..7b477c4 100644 --- a/src/Runner.hs +++ b/src/Runner.hs @@ -2,11 +2,14 @@ {-# LANGUAGE LambdaCase #-} module Runner ( runModules +, Verbose(..) , Summary(..) +, formatSummary #ifdef TEST , Report -, ReportState (..) +, ReportState(..) +, Interactive(..) , report , reportTransient #endif @@ -16,10 +19,11 @@ import Prelude () import Imports hiding (putStr, putStrLn, error) import Text.Printf (printf) -import System.IO (hGetBuffering, hSetBuffering, BufferMode(..), hFlush, hPutStrLn, hPutStr, stderr, hIsTerminalDevice) +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 @@ -36,10 +40,12 @@ data Summary = Summary { , 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 @@ -52,35 +58,59 @@ instance Semigroup Summary where #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 = bracket (hGetBuffering stderr) (hSetBuffering stderr) $ \ _ -> do - hSetBuffering stderr LineBuffering +runModules :: Bool -> Bool -> Verbose -> Interpreter -> [Module [Located DocTest]] -> IO Summary +runModules fastMode preserveIt verbose repl modules = withLineBuffering stderr $ do + + interactive <- hIsTerminalDevice stderr <&> \ case + False -> NonInteractive + True -> Interactive + + summary <- newIORef mempty {sExamples = n} - isInteractive <- hIsTerminalDevice stderr - ReportState _ _ s <- (`execStateT` ReportState isInteractive verbose mempty {sExamples = c}) $ do - forM_ modules $ runModule fastMode preserveIt repl + let + reportFinalResult :: IO () + reportFinalResult = do + final <- readIORef summary + hPutStrLn stderr (formatSummary final) - verboseReport "# Final summary:" - gets (show . reportStateSummary) >>= report + run :: IO () + run = flip evalStateT (ReportState interactive verbose summary) $ do + reportProgress + forM_ modules $ runModule fastMode preserveIt repl + verboseReport "# Final summary:" - return s + 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 { - 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 = liftIO . hPutStrLn stderr @@ -90,24 +120,23 @@ report = liftIO . hPutStrLn stderr -- This will be overwritten by subsequent calls to `report`/`report_`. -- Intermediate out may not contain any newlines. 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" +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) $ @@ -160,20 +189,22 @@ reportSuccess = do 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 f v s <- get - put (ReportState 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) >>= reportTransient +reportProgress = gets reportStateVerbose >>= \ case + NonVerbose -> do + summary <- getSummary + reportTransient (formatSummary summary) + Verbose -> pass -- | Run given test group. -- diff --git a/test/MainSpec.hs b/test/MainSpec.hs index 6cdd5be..2fad7d5 100644 --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -26,7 +26,7 @@ doctest = doctestWithPreserveIt False 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 index e48b09e..abd1185 100644 --- a/test/RunnerSpec.hs +++ b/test/RunnerSpec.hs @@ -1,49 +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 True False mempty) - --- like capture, but with interactivity set to False -capture_ :: Report a -> IO String -capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 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" 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 transient output to stderr" $ do - capture $ do + capture Interactive $ do reportTransient "foobar" `shouldReturn` "foobar\r \r" context "when mode is non-interactive" $ do it "is ignored" $ do - capture_ $ do + capture NonInteractive $ do reportTransient "foobar" `shouldReturn` ""