diff options
Diffstat (limited to 'test-framework/Test/Framework.hs')
| -rw-r--r-- | test-framework/Test/Framework.hs | 89 |
1 files changed, 58 insertions, 31 deletions
diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs index e83d0de..1b2b7d7 100644 --- a/test-framework/Test/Framework.hs +++ b/test-framework/Test/Framework.hs @@ -18,7 +18,7 @@ module Test.Framework ( TestName, ) where -import Control.Monad (forM) +import Control.Monad (forM, when) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class import Data.List (isInfixOf, intercalate) @@ -27,7 +27,7 @@ import Data.String (fromString) import Data.Time.Clock import System.Environment import System.Exit -import System.IO (hFlush, hPutStrLn, stdout, stderr) +import System.IO (hFlush, hPutStrLn, stdout, stderr, hIsTerminalDevice) import Text.Read (readMaybe) import qualified Hedgehog as H @@ -106,11 +106,13 @@ modifyStats f = M (modify f) data Options = Options { optsPattern :: String , optsHelp :: Bool - , optsHedgehogReplay :: Maybe (H.Skip, H.Seed) } + , optsHedgehogReplay :: Maybe (H.Skip, H.Seed) + , optsHedgehogShrinks :: Maybe Int + } deriving (Show) defaultOptions :: Options -defaultOptions = Options "" False Nothing +defaultOptions = Options "" False Nothing Nothing parseOptions :: [String] -> Options -> Either String Options parseOptions [] opts = pure opts @@ -128,6 +130,10 @@ parseOptions ("--hedgehog-replay":arg:args) opts Just res -> parseOptions args opts { optsHedgehogReplay = Just res } Nothing -> Left "Invalid argument to '--hedgehog-replay'" | otherwise = Left "Multiple '--hedgehog-replay' arguments given" +parseOptions ("--hedgehog-shrinks":arg:args) opts = + case readMaybe arg of + Just n -> parseOptions args opts { optsHedgehogShrinks = Just n } + Nothing -> Left "Invalid argument to '--hedgehog-shrinks'" parseOptions (arg:_) _ = Left $ "Unrecognised argument: '" ++ arg ++ "'" printUsage :: IO () @@ -158,30 +164,33 @@ runTests options = \tree' -> Nothing -> do hPutStrLn stderr "No tests matched the given pattern." return (ExitFailure 1) Just tree -> do - let M m = let ?maxlen = computeMaxLen tree in go 0 id tree + isterm <- hIsTerminalDevice stdout + let M m = let ?maxlen = computeMaxLen tree + ?istty = isterm + in go 0 id tree starttm <- getCurrentTime (success, stats) <- runStateT m initStats endtm <- getCurrentTime - printStats stats (diffUTCTime endtm starttm) + let ?istty = isterm in printStats stats (diffUTCTime endtm starttm) return (if isJust success then ExitSuccess else ExitFailure 1) where -- If all tests are successful, returns the number of output lines produced - go :: (?maxlen :: Int) => Int -> (String -> String) -> TestTree -> M (Maybe Int) + go :: (?maxlen :: Int, ?istty :: Bool) => Int -> (String -> String) -> TestTree -> M (Maybe Int) go indent path (Group collapse name trees) = do - liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name) + liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name) >> hFlush stdout starttm <- liftIO getCurrentTime mlns <- fmap (fmap sum . sequence) . forM trees $ go (indent + 1) (path . (name++) . ('/':)) endtm <- liftIO getCurrentTime case mlns of - Just lns | collapse -> do + Just lns | collapse, ?istty -> do let thislen = 2*indent + length name liftIO $ putStrLn $ concat (replicate (lns+1) "\x1B[A\x1B[2K") ++ "\x1B[G" ++ replicate (2 * indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' ++ "\x1B[32mOK\x1B[0m" ++ prettyDuration False (realToFrac (diffUTCTime endtm starttm)) return (Just 1) - _ -> return mlns + _ -> return ((+1) <$> mlns) go indent path (Resource make cleanup fun) = do value <- liftIO make success <- go indent path (fun value) @@ -189,52 +198,66 @@ runTests options = \tree' -> return success go indent path (HP name (H.Property config test)) = do let thislen = 2*indent + length name - liftIO $ putStr (replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ') - liftIO $ hFlush stdout + let outputPrefix = replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' + when ?istty $ liftIO $ putStr outputPrefix >> hFlush stdout - (config', seed) <- case optsHedgehogReplay options of - Just (skip, seed) -> return (config { H.propertySkip = Just skip }, seed) - Nothing -> (config,) <$> H.Seed.random + let (config', seedfun) = applyHedgehogOptions options config + seed <- seedfun starttm <- liftIO getCurrentTime report <- liftIO $ H.checkReport config' 0 seed test (outputProgress (?maxlen + 2)) endtm <- liftIO getCurrentTime - liftIO $ printResult report (path name) (diffUTCTime endtm starttm) + liftIO $ do + when (not ?istty) $ putStr outputPrefix + printResult report (path name) (diffUTCTime endtm starttm) + hFlush stdout let ok = H.reportStatus report == H.OK modifyStats $ \stats -> stats { statsOK = fromEnum ok + statsOK stats , statsTotal = 1 + statsTotal stats } return (if ok then Just 1 else Nothing) -outputProgress :: Int -> H.Report H.Progress -> IO () -outputProgress indent report = do - str <- H.renderProgress H.EnableColor (Just (fromString "")) report - putStr (replace '\n' " " str ++ "\x1B[" ++ show (indent+1) ++ "G") - hFlush stdout - -printResult :: H.Report H.Result -> String -> NominalDiffTime -> IO () +applyHedgehogOptions :: MonadIO m => Options -> H.PropertyConfig -> (H.PropertyConfig, m H.Seed) +applyHedgehogOptions opts config0 = + let (f1, seedfun) = case optsHedgehogReplay opts of + Just (skip, seed) -> (\c -> c { H.propertySkip = Just skip }, return seed) + Nothing -> (id, H.Seed.random) + f2 = case optsHedgehogShrinks opts of + Just n -> \c -> c { H.propertyShrinkLimit = H.ShrinkLimit n } + Nothing -> id + in (f2 . f1 $ config0, seedfun) + +outputProgress :: (?istty :: Bool) => Int -> H.Report H.Progress -> IO () +outputProgress indent report + | ?istty = do + str <- H.renderProgress H.EnableColor (Just (fromString "")) report + putStr (replace '\n' " " str ++ "\x1B[" ++ show (indent+1) ++ "G") + hFlush stdout + | otherwise = return () + +printResult :: (?istty :: Bool) => H.Report H.Result -> String -> NominalDiffTime -> IO () printResult report path timeTaken = do str <- H.renderResult H.EnableColor (Just (fromString "")) report case H.reportStatus report of - H.OK -> putStrLn ("\x1B[K" ++ str ++ prettyDuration False (realToFrac timeTaken)) + H.OK -> putStrLn (ansi "\x1B[K" ++ str ++ prettyDuration False (realToFrac timeTaken)) H.Failed failure -> do let H.Report { H.reportTests = count, H.reportDiscards = discards } = report replayInfo = H.skipCompress (H.SkipToShrink count discards (H.failureShrinkPath failure)) ++ " " ++ show (H.reportSeed report) suffix = "\n Flags to reproduce: `-p '" ++ path ++ "' --hedgehog-replay '" ++ replayInfo ++ "'`" - putStrLn ("\x1B[K" ++ str ++ suffix) - _ -> putStrLn ("\x1B[K" ++ str) + putStrLn (ansi "\x1B[K" ++ str ++ suffix) + _ -> putStrLn (ansi "\x1B[K" ++ str) -printStats :: Stats -> NominalDiffTime -> IO () +printStats :: (?istty :: Bool) => Stats -> NominalDiffTime -> IO () printStats stats timeTaken | statsOK stats == statsTotal stats = do - putStrLn $ "\x1B[32mAll " ++ show (statsTotal stats) ++ - " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m" + putStrLn $ ansi "\x1B[32m" ++ "All " ++ show (statsTotal stats) ++ + " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ ansi "\x1B[0m" | otherwise = let nfailed = statsTotal stats - statsOK stats - in putStrLn $ "\x1B[31mFailed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++ - " tests." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m" + in putStrLn $ ansi "\x1B[31m" ++ "Failed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++ + " tests." ++ prettyDuration True (realToFrac timeTaken) ++ ansi "\x1B[0m" prettyDuration :: Bool -> Double -> String prettyDuration False x | x < 0.5 = "" @@ -246,3 +269,7 @@ prettyDuration _ x = replace :: Eq a => a -> [a] -> [a] -> [a] replace x ys = concatMap (\y -> if y == x then ys else [y]) + +ansi :: (?istty :: Bool) => String -> String +ansi | ?istty = id + | otherwise = const "" |