Apply patch for fixed seed with minor modifications.

Mostly copied from #201 (comment)
hedgehogqa · Jan 29, 2022 · 2d84438 · 2d84438
1 parent c7d7a27
commit 2d84438
Show file tree

Hide file tree

Showing 3 changed files with 50 additions and 7 deletions.
diff --git a/hedgehog/src/Hedgehog/Internal/Config.hs b/hedgehog/src/Hedgehog/Internal/Config.hs
@@ -9,6 +9,9 @@ module Hedgehog.Internal.Config (
     UseColor(..)
   , resolveColor
 
+  , Seed(..)
+  , resolveSeed
+
   , Verbosity(..)
   , resolveVerbosity
 
@@ -17,14 +20,20 @@ module Hedgehog.Internal.Config (
 
   , detectMark
   , detectColor
+  , detectSeed
   , detectVerbosity
   , detectWorkers
   ) where
 
 import           Control.Monad.IO.Class (MonadIO(..))
 
+import qualified Data.Text as Text
+
 import qualified GHC.Conc as Conc
 
+import           Hedgehog.Internal.Seed (Seed(..))
+import qualified Hedgehog.Internal.Seed as Seed
+
 import           Language.Haskell.TH.Syntax (Lift)
 
 import           System.Console.ANSI (hSupportsANSI)
@@ -107,6 +116,20 @@ detectColor =
           else
             pure DisableColor
 
+detectSeed :: MonadIO m => m Seed
+detectSeed =
+  liftIO $ do
+    menv <- lookupEnv "HEDGEHOG_SEED"
+    case menv of
+      Nothing ->
+        Seed.random
+      Just env ->
+        let
+          [value, gamma] =
+            read . Text.unpack <$> Text.splitOn (Text.pack " ") (Text.pack env)
+        in
+          pure $ Seed value gamma
+
 detectVerbosity :: MonadIO m => m Verbosity
 detectVerbosity =
   liftIO $ do
@@ -142,6 +165,13 @@ resolveColor = \case
   Just x ->
     pure x
 
+resolveSeed :: MonadIO m => Maybe Seed -> m Seed
+resolveSeed = \case
+  Nothing ->
+    detectSeed
+  Just x ->
+    pure x
+
 resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity
 resolveVerbosity = \case
   Nothing ->

diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs
@@ -71,6 +71,9 @@ data RunnerConfig =
       --   the environment.
     , runnerColor :: !(Maybe UseColor)
 
+      -- | The seed to use. 'Nothing' means detect from the environment.
+    , runnerSeed :: !(Maybe Seed)
+
       -- | How verbose to be in the runner output. 'Nothing' means detect from
       --   the environment.
     , runnerVerbosity :: !(Maybe Verbosity)
@@ -331,10 +334,11 @@ checkNamed ::
   => Region
   -> UseColor
   -> Maybe PropertyName
+  -> Maybe Seed
   -> Property
   -> m (Report Result)
-checkNamed region color name prop = do
-  seed <- liftIO Seed.random
+checkNamed region color name mseed prop = do
+  seed <- resolveSeed mseed
   checkRegion region color name 0 seed prop
 
 -- | Check a property.
@@ -343,7 +347,7 @@ check :: MonadIO m => Property -> m Bool
 check prop = do
   color <- detectColor
   liftIO . displayRegion $ \region ->
-    (== OK) . reportStatus <$> checkNamed region color Nothing prop
+    (== OK) . reportStatus <$> checkNamed region color Nothing Nothing prop
 
 -- | Check a property using a specific size and seed.
 --
@@ -373,9 +377,10 @@ checkGroup config (Group group props) =
 
     putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"
 
+    seed <- resolveSeed (runnerSeed config)
     verbosity <- resolveVerbosity (runnerVerbosity config)
     color <- resolveColor (runnerColor config)
-    summary <- checkGroupWith n verbosity color props
+    summary <- checkGroupWith n verbosity color seed props
 
     pure $
       summaryFailed summary == 0 &&
@@ -390,9 +395,10 @@ checkGroupWith ::
      WorkerCount
   -> Verbosity
   -> UseColor
+  -> Seed
   -> [(PropertyName, Property)]
   -> IO Summary
-checkGroupWith n verbosity color props =
+checkGroupWith n verbosity color seed props =
   displayRegion $ \sregion -> do
     svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) }
 
@@ -430,7 +436,7 @@ checkGroupWith n verbosity color props =
     summary <-
       fmap (mconcat . fmap (fromResult . reportStatus)) $
         runTasks n props start finish finalize $ \(name, prop, region) -> do
-          result <- checkNamed region color (Just name) prop
+          result <- checkNamed region color (Just name) (Just seed) prop
           updateSummary sregion svar color
             (<> fromResult (reportStatus result))
           pure result
@@ -463,6 +469,8 @@ checkSequential =
           Just 1
       , runnerColor =
           Nothing
+      , runnerSeed =
+          Nothing
       , runnerVerbosity =
           Nothing
       }
@@ -497,6 +505,8 @@ checkParallel =
           Nothing
       , runnerColor =
           Nothing
+      , runnerSeed =
+          Nothing
       , runnerVerbosity =
           Nothing
       }
diff --git a/hedgehog/src/Hedgehog/Internal/Seed.hs b/hedgehog/src/Hedgehog/Internal/Seed.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_HADDOCK not-home #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveLift #-}
 -- |
 -- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele
 -- et. al. [1].
@@ -61,6 +62,8 @@ import           Data.IORef (IORef)
 import qualified Data.IORef as IORef
 import           Data.Word (Word32, Word64)
 
+import           Language.Haskell.TH.Syntax (Lift)
+
 import           System.IO.Unsafe (unsafePerformIO)
 import           System.Random (RandomGen)
 import qualified System.Random as Random
@@ -71,7 +74,7 @@ data Seed =
   Seed {
       seedValue :: !Word64
     , seedGamma :: !Word64 -- ^ must be an odd number
-    } deriving (Eq, Ord)
+    } deriving (Eq, Ord, Lift)
 
 instance Show Seed where
   showsPrec p (Seed v g) =