aboutsummaryrefslogtreecommitdiff
path: root/test-framework/Test
diff options
context:
space:
mode:
Diffstat (limited to 'test-framework/Test')
-rw-r--r--test-framework/Test/Framework.hs137
1 files changed, 95 insertions, 42 deletions
diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs
index 4c7799b..1b2b7d7 100644
--- a/test-framework/Test/Framework.hs
+++ b/test-framework/Test/Framework.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TupleSections #-}
module Test.Framework (
TestTree,
testGroup,
@@ -17,16 +18,17 @@ 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)
+import Data.List (isInfixOf, intercalate)
import Data.Maybe (isJust, mapMaybe, fromJust)
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
import qualified Hedgehog.Internal.Config as H
@@ -62,10 +64,10 @@ testProperty :: String -> H.Property -> TestTree
testProperty = HP
filterTree :: Options -> TestTree -> Maybe TestTree
-filterTree (Options { optsPattern = pat }) = go ""
+filterTree (Options { optsPattern = pat }) = go []
where
go path (Group collapse name trees) =
- case mapMaybe (go (path++"/"++name)) trees of
+ case mapMaybe (go (name:path)) trees of
[] -> Nothing
trees' -> Just (Group collapse name trees')
go path (Resource make free fun) =
@@ -73,9 +75,11 @@ filterTree (Options { optsPattern = pat }) = go ""
Nothing -> Nothing
Just _ -> Just $ Resource make free (fromJust . go path . fun)
go path hp@(HP name _)
- | pat `isInfixOf` (path ++ "/" ++ name) = Just hp
+ | pat `isInfixOf` renderPath (name:path) = Just hp
| otherwise = Nothing
+ renderPath comps = "^" ++ intercalate "/" (reverse comps) ++ "$"
+
computeMaxLen :: TestTree -> Int
computeMaxLen = go 0
where
@@ -101,11 +105,14 @@ modifyStats f = M (modify f)
data Options = Options
{ optsPattern :: String
- , optsHelp :: Bool }
+ , optsHelp :: Bool
+ , optsHedgehogReplay :: Maybe (H.Skip, H.Seed)
+ , optsHedgehogShrinks :: Maybe Int
+ }
deriving (Show)
defaultOptions :: Options
-defaultOptions = Options "" False
+defaultOptions = Options "" False Nothing Nothing
parseOptions :: [String] -> Options -> Either String Options
parseOptions [] opts = pure opts
@@ -114,6 +121,19 @@ parseOptions ("--help":args) opts = parseOptions args opts { optsHelp = True }
parseOptions ("-p":arg:args) opts
| optsPattern opts == "" = parseOptions args opts { optsPattern = arg }
| otherwise = Left "Multiple '-p' arguments given"
+parseOptions ("--hedgehog-replay":arg:args) opts
+ | Nothing <- optsHedgehogReplay opts =
+ let parsed = do
+ (skipstr, ' ' : seedstr) <- return $ span (/= ' ') arg
+ (,) <$> H.skipDecompress skipstr <*> readMaybe seedstr
+ in case parsed of
+ 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 ()
@@ -124,7 +144,10 @@ printUsage = do
,"Options:"
," -h / --help Show this help"
," -p PATTERN Only tests whose path contains PATTERN are run. The path of a"
- ," test looks like: '/group1/group2/testname'."]
+ ," test looks like: '^group1/group2/testname$'."
+ ," --hedgehog-replay '{skip} {seed}'"
+ ," Skip to a particular generated Hedgehog test. Should be used"
+ ," with -p. Overrides 'propertySkip' in 'PropertyConfig' if set."]
defaultMain :: TestTree -> IO ()
defaultMain tree = do
@@ -141,74 +164,100 @@ 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 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 -> TestTree -> M (Maybe Int)
- go indent (Group collapse name trees) = do
- liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name)
+ 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) >> hFlush stdout
starttm <- liftIO getCurrentTime
- mlns <- fmap (fmap sum . sequence) . forM trees $ go (indent + 1)
+ 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
- go indent (Resource make cleanup fun) = do
+ _ -> return ((+1) <$> mlns)
+ go indent path (Resource make cleanup fun) = do
value <- liftIO make
- success <- go indent (fun value)
+ success <- go indent path (fun value)
liftIO $ cleanup value
return success
- go indent (HP name (H.Property config test)) = do
+ 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
- seed <- 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))
+ report <- liftIO $ H.checkReport config' 0 seed test (outputProgress (?maxlen + 2))
endtm <- liftIO getCurrentTime
- liftIO $ printResult report (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 -> NominalDiffTime -> IO ()
-printResult report timeTaken = do
+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
- if H.reportStatus report == H.OK
- then putStrLn ("\x1B[K" ++ str ++ prettyDuration False (realToFrac timeTaken))
- else putStrLn ("\x1B[K" ++ str)
-
-printStats :: Stats -> NominalDiffTime -> IO ()
+ case H.reportStatus report of
+ 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 (ansi "\x1B[K" ++ str ++ suffix)
+ _ -> putStrLn (ansi "\x1B[K" ++ str)
+
+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 = ""
@@ -220,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 ""
generated by cgit v1.2.3-70-g09d2 (git 2.48.1) at 2025-07-05 15:36:25 +0200