Apply patch for fixed seed (#446)

* Apply patch for fixed seed with minor modifications.

Mostly copied from
#201 (comment)

* Remove redundant imports.

* Make seed parsing code total

Co-authored-by: Scott Fleischman <fleischman@simspace.com>

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,28 @@ detectColor =
           else
             pure DisableColor
 
+splitOn :: String -> String -> [String]
+splitOn needle haystack =
+  fmap Text.unpack $ Text.splitOn (Text.pack needle) (Text.pack haystack)
+
+parseSeed :: String -> Maybe Seed
+parseSeed env =
+  case splitOn " " env of
+    [value, gamma] ->
+      Seed <$> readMaybe value <*> readMaybe gamma
+    _ ->
+      Nothing
+
+detectSeed :: MonadIO m => m Seed
+detectSeed =
+  liftIO $ do
+    menv <- lookupEnv "HEDGEHOG_SEED"
+    case parseSeed =<< menv of
+      Nothing ->
+        Seed.random
+      Just seed ->
+        pure seed
+
 detectVerbosity :: MonadIO m => m Verbosity
 detectVerbosity =
   liftIO $ do
@@ -142,6 +173,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 ->

hedgehog/src/Hedgehog/Internal/Report.hs

@@ -63,7 +63,6 @@ import           Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))
 import           Hedgehog.Internal.Property (coverPercentage, coverageFailures)
 import           Hedgehog.Internal.Property (labelCovered)
 
-import           Hedgehog.Internal.Seed (Seed)
 import           Hedgehog.Internal.Show
 import           Hedgehog.Internal.Source
 import           Hedgehog.Range (Size)

hedgehog/src/Hedgehog/Internal/Runner.hs

@@ -48,7 +48,6 @@ import           Hedgehog.Internal.Property (defaultMinTests)
 import           Hedgehog.Internal.Queue
 import           Hedgehog.Internal.Region
 import           Hedgehog.Internal.Report
-import           Hedgehog.Internal.Seed (Seed)
 import qualified Hedgehog.Internal.Seed as Seed
 import           Hedgehog.Internal.Tree (TreeT(..), NodeT(..))
 import           Hedgehog.Range (Size)
@@ -71,6 +70,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 +333,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 +346,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 +376,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 +394,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 +435,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 +468,8 @@ checkSequential =
           Just 1
       , runnerColor =
           Nothing
+      , runnerSeed =
+          Nothing
       , runnerVerbosity =
           Nothing
       }
@@ -497,6 +504,8 @@ checkParallel =
           Nothing
       , runnerColor =
           Nothing
+      , runnerSeed =
+          Nothing
       , runnerVerbosity =
           Nothing
       }

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) =