test-framework: --hedgehog-replay

1 files changed, 43 insertions, 19 deletions

diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs
index 4c7799b..158c489 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,
@@ -27,6 +28,7 @@ import Data.Time.Clock
 import System.Environment
 import System.Exit
 import System.IO (hFlush, hPutStrLn, stdout, stderr)
+import Text.Read (readMaybe)
 
 import qualified Hedgehog as H
 import qualified Hedgehog.Internal.Config as H
@@ -73,7 +75,7 @@ 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` (path++"/"++name) = Just hp
       | otherwise = Nothing
 
 computeMaxLen :: TestTree -> Int
@@ -101,11 +103,12 @@ modifyStats f = M (modify f)
 
 data Options = Options
   { optsPattern :: String
-  , optsHelp :: Bool }
+  , optsHelp :: Bool
+  , optsHedgehogReplay :: Maybe (H.Skip, H.Seed) }
   deriving (Show)
 
 defaultOptions :: Options
-defaultOptions = Options "" False
+defaultOptions = Options "" False Nothing
 
 parseOptions :: [String] -> Options -> Either String Options
 parseOptions [] opts = pure opts
@@ -114,6 +117,15 @@ 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 (arg:_) _ = Left $ "Unrecognised argument: '" ++ arg ++ "'"
 
 printUsage :: IO ()
@@ -124,7 +136,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,7 +156,7 @@ 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
+      let M m = let ?maxlen = computeMaxLen tree in go 0 id tree
       starttm <- getCurrentTime
       (success, stats) <- runStateT m initStats
       endtm <- getCurrentTime
@@ -149,11 +164,12 @@ runTests options = \tree' ->
       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
+    go :: (?maxlen :: Int) => Int -> (String -> String) -> TestTree -> M (Maybe Int)
+    go indent path (Group collapse name trees) = do
       liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name)
       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
@@ -164,23 +180,25 @@ runTests options = \tree' ->
                               prettyDuration False (realToFrac (diffUTCTime endtm starttm))
           return (Just 1)
         _ -> return mlns
-    go indent (Resource make cleanup fun) = do
+    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
 
-      seed <- H.Seed.random
+      (config', seed) <- case optsHedgehogReplay options of
+                           Just (skip, seed) -> return (config { H.propertySkip = Just skip }, seed)
+                           Nothing -> (config,) <$> H.Seed.random
 
       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 $ printResult report (path name) (diffUTCTime endtm starttm)
 
       let ok = H.reportStatus report == H.OK
       modifyStats $ \stats -> stats { statsOK = fromEnum ok + statsOK stats
@@ -193,12 +211,18 @@ outputProgress indent report = do
   putStr (replace '\n' "  " str ++ "\x1B[" ++ show (indent+1) ++ "G")
   hFlush stdout
 
-printResult :: H.Report H.Result -> NominalDiffTime -> IO ()
-printResult report timeTaken = do
+printResult :: 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)
+  case H.reportStatus report of
+    H.OK -> putStrLn ("\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)
 
 printStats :: Stats -> NominalDiffTime -> IO ()
 printStats stats timeTaken