Merge pull request #98 from lehins/lehins/add-random-seed-instance-al…

…ternative

V2: Add an instance for the new SeedGen type class

System/Random/MWC.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, FlexibleContexts,
+{-# LANGUAGE BangPatterns, CPP, DataKinds, DeriveDataTypeable, FlexibleContexts,
     FlexibleInstances, MultiParamTypeClasses, MagicHash, Rank2Types,
     ScopedTypeVariables, TypeFamilies, UnboxedTuples, TypeOperators
     #-}
@@ -177,6 +177,9 @@ import System.IO.Unsafe (unsafePerformIO)
 import qualified Control.Exception as E
 import System.Random.MWC.SeedSource
 import qualified System.Random.Stateful as Random
+#if MIN_VERSION_random(1,3,0)
+import Data.List.NonEmpty      (NonEmpty(..), toList)
+#endif
 
 -- | NOTE: Consider use of more principled type classes
 -- 'Random.Uniform' and 'Random.UniformRange' instead.
@@ -486,6 +489,28 @@ instance PrimMonad m => Random.ThawedGen Seed m where
 #endif
   thawGen = restore
 
+#if MIN_VERSION_random(1,3,0)
+instance Random.SeedGen Seed where
+  type SeedSize Seed = 1032 -- == 4 * 258
+  fromSeed64 seed64 = toSeed $ I.fromListN 258
+    [ w32
+    | !w64 <- toList seed64
+    , !w32 <- [ fromIntegral (w64 `shiftR` 32)
+              , fromIntegral w64 ]
+    ]
+  toSeed64 vSeed =
+    let w32sToW64 :: Word32 -> Word32 -> Word64
+        w32sToW64 w32u w32l =
+          (fromIntegral w32u `shiftL` 32) .|. fromIntegral w32l
+        v = fromSeed vSeed
+        evens = I.ifilter (\i _ -> even i) v
+        odds = I.ifilter (\i _ -> odd i) v
+     in case I.toList $ I.zipWith w32sToW64 evens odds of
+          [] ->
+            error $ "Impossible: Seed had an unexpected length of: " ++ show (I.length v)
+          x:xs -> x :| xs
+#endif
+
 -- | Convert vector to 'Seed'. It acts similarly to 'initialize' and
 -- will accept any vector. If you want to pass seed immediately to
 -- restore you better call initialize directly since following law holds:

bench/Benchmark.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP          #-}
 module Main(main) where
 
 import Control.Exception
@@ -48,8 +49,9 @@ main = do
   opts <- parseOptions ingredients (bench "Fake" (nf id ()))
   let iter = lookupOption opts
   -- Set up RNG
-  mwc <- create
-  mtg <- M.newMTGen . Just =<< uniform mwc
+  mwc  <- create
+  seed <- save mwc
+  mtg  <- M.newMTGen . Just =<< uniform mwc
   defaultMainWithIngredients ingredients $ bgroup "All"
     [ bgroup "mwc"
       -- One letter group names are used so they will fit on the plot.
@@ -148,6 +150,13 @@ main = do
         bench "Double" $ whnfIO $ loop iter (M.random mtg :: IO Double)
       , bench "Int"    $ whnfIO $ loop iter (M.random mtg :: IO Int)
       ]
+#if MIN_VERSION_random(1,3,0)
+    , bgroup "seed"
+      [ bench "SeedGen.fromSeed" $ let rseed = R.toSeed seed :: R.Seed Seed
+                                   in whnf R.fromSeed rseed
+      , bench "SeedGen.toSeed"   $ whnf R.toSeed seed
+      ]
+#endif
     ]
 
 betaBinomial :: StatefulGen g m => Double -> Double -> Int -> g -> m Int

tests/props.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP          #-}
 {-# LANGUAGE ViewPatterns #-}
 import Control.Monad
 import Data.Word
@@ -16,6 +17,9 @@ import Test.QuickCheck.Monadic
 import System.Random.MWC
 import System.Random.MWC.Distributions
 import System.Random.Stateful (StatefulGen)
+#if MIN_VERSION_random(1,3,0)
+import qualified System.Random.Stateful as Random (SeedGen(..))
+#endif
 
 ----------------------------------------------------------------
 --
@@ -65,6 +69,9 @@ main = do
   g0 <- createSystemRandom
   defaultMainWithIngredients ingredients $ testGroup "mwc"
     [ testProperty "save/restore"      $ prop_SeedSaveRestore g0
+#if MIN_VERSION_random(1,3,0)
+    , testProperty "SeedGen"           $ prop_SeedGen g0
+#endif
     , testCase     "user save/restore" $ saveRestoreUserSeed
     , testCase     "empty seed data"   $ emptySeed
     , testCase     "output correct"    $ do
@@ -76,8 +83,7 @@ main = do
     ]
 
 updateGenState :: GenIO -> IO ()
-updateGenState g = replicateM_ 256 (uniform g :: IO Word32)
-
+updateGenState g = replicateM_ 250 (uniform g :: IO Word32)
 
 prop_SeedSaveRestore :: GenIO -> Property
 prop_SeedSaveRestore g = monadicIO  $ do
@@ -86,6 +92,14 @@ prop_SeedSaveRestore g = monadicIO  $ do
   seed' <- run $ save =<< restore seed
   return $ seed == seed'
 
+#if MIN_VERSION_random(1,3,0)
+prop_SeedGen :: GenIO -> Property
+prop_SeedGen g = monadicIO $ do
+  run $ updateGenState g
+  seed <- run $ save g
+  return $ seed == (Random.fromSeed . Random.toSeed) seed
+#endif
+
 saveRestoreUserSeed :: IO ()
 saveRestoreUserSeed = do
   let seed = toSeed $ U.replicate 258 0