BitStringRandomMonad 1.0.0.1 → 1.1.0.2
raw patch · 3 files changed
+51/−31 lines, 3 filesdep +deepseq
Dependencies added: deepseq
Files
- BitStringRandomMonad.cabal +3/−1
- Crypto/RandomMonad.hs +43/−26
- Test/Tests.hs +5/−4
BitStringRandomMonad.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: BitStringRandomMonad-version: 1.0.0.1+version: 1.1.0.2 description: A library which turns a bytestring into a random monad. Input could be any PRNG which can output a lazy bytestring.@@ -26,6 +26,7 @@ mtl, primitive, parallel,+ deepseq, vector -- hs-source-dirs:@@ -45,6 +46,7 @@ parallel, vector, BitStringRandomMonad+ default-language: Haskell2010 Source-Repository head Type: git
Crypto/RandomMonad.hs view
@@ -4,21 +4,24 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE GADTs #-} -module Crypto.RandomMonad (RndT, RndST, RndIO, Rnd, RndState, getRandomM, getRandom2M, runRndT, newRandomElementST, getRandomElement, randomElementsLength, replaceSeedM, addSeedM, getRandomByteStringM, RandomElementsListST, RndStateList(..), BitStringToRandomExceptions(..)) where+module Crypto.RandomMonad (RndT, RndST, RndIO, Rnd, RndState, getRandomM, getRandom2M, runRndT, newRandomElementST, getRandomElement, randomElementsLength, replaceSeedM, addSeedM, getRandomByteStringM, RandomElementsListST, RndStateList(..), RndStateParallelization(..), BitStringToRandomExceptions(..), seedFromBytestrings, seedFromBytestringsThreaded, seedFromBytestringsM) where +import Control.DeepSeq (deepseq, force) import Control.Exception (Exception, throw) import Control.Monad.Identity (Identity) import Control.Monad.Primitive (PrimMonad, PrimState, primitive) import Control.Monad.ST (ST) import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.State.Lazy (StateT, put, state, runStateT)+import Control.Parallel (par, pseq) import Control.Parallel.Strategies (parMap, rpar, using, rseq) import Data.Bits (shiftL, (.|.), xor)-import Data.Typeable (Typeable) import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Data.Typeable (Typeable) import qualified Data.BitString as BS-import qualified Data.ByteString.Lazy as ByS+import qualified Data.ByteString as ByS+import qualified Data.ByteString.Lazy as ByLS import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as VM @@ -34,17 +37,18 @@ convert' :: Integer -> Bool -> Integer convert' prev cur = (shiftL prev 1) .|. (case cur of True -> 1 ; False -> 0) -multipleBitstringsSplitAt i (RndStateListSequencial [x]) = let (takers, droppers) = BS.splitAt i x in ([takers], RndStateListSequencial [droppers])-multipleBitstringsSplitAt i (RndStateListSequencial x) = join' (split' x) [] []+multipleBitstringsSplitAt i (RndStateList RndStateParallel [x]) = let (takers, droppers) = BS.splitAt i x in ([takers], RndStateList RndStateParallel [droppers])+multipleBitstringsSplitAt i (RndStateList RndStateParallel x) = join' (split' x) [] [] where- split' = map $ BS.splitAt i- join' [] takers droppers = (takers, RndStateListSequencial droppers)+ split' = parMap rpar (\bs -> let (take,drop) = BS.splitAt i bs in (take `using` rseq, drop))+ join' [] takers droppers = (takers, RndStateList RndStateParallel droppers) join' (x:xs) takers droppers = let (newTake, newDrop) = x in join' xs (newTake:takers) (newDrop:droppers)-multipleBitstringsSplitAt i (RndStateListParallel [x]) = let (takers, droppers) = BS.splitAt i x in ([takers], RndStateListParallel [droppers])-multipleBitstringsSplitAt i (RndStateListParallel x) = join' (split' x) [] []++multipleBitstringsSplitAt i (RndStateList p [x]) = let (takers, droppers) = BS.splitAt i x in ([takers], RndStateList p [droppers])+multipleBitstringsSplitAt i (RndStateList p x) = join' (split' x) [] [] where- split' = parMap rpar (\bs -> let (take,drop) = BS.splitAt i bs in (take `using` rseq, drop))- join' [] takers droppers = (takers, RndStateListParallel droppers)+ split' = map $ BS.splitAt i+ join' [] takers droppers = (takers, RndStateList p droppers) join' (x:xs) takers droppers = let (newTake, newDrop) = x in join' xs (newTake:takers) (newDrop:droppers) multipleBitstringsAssertLength _ [] = False@@ -85,18 +89,18 @@ getRandomElement :: (RandomElementsListST a s) -> RndST s a getRandomElement (RandomElementsListST ref) = do- vec <- lift $ readSTRef ref- vec' <- lift $ V.unsafeThaw vec- let n = toInteger $ VM.length vec'+ mut <- lift $ readSTRef ref >>= V.unsafeThaw+ let n = toInteger $ VM.length mut j <- if n > 0 then getRandomM $ n - 1 else throw OutOfElementsException let j' = fromInteger j- aa <- lift $ VM.read vec' 0- ab <- lift $ VM.read vec' j'- lift $ VM.write vec' j' aa- vec'' <- lift $ V.unsafeFreeze vec'- lift $ writeSTRef ref $ V.unsafeTail vec''- return ab+ lift $ do+ aa <- VM.read mut 0+ ab <- VM.read mut j'+ VM.write mut j' aa+ vec <- V.unsafeFreeze mut+ writeSTRef ref $ V.unsafeTail vec+ return ab randomElementsLength :: RandomElementsListST a s -> RndST s Int randomElementsLength (RandomElementsListST ref) = do@@ -104,8 +108,8 @@ return $ V.length vec type RndStatePrimitive = [BS.BitString]-data RndStateList = RndStateListSequencial RndStatePrimitive- | RndStateListParallel RndStatePrimitive+data RndStateParallelization = RndStateSeq | RndStatePrecalculate | RndStateParallel+data RndStateList = RndStateList RndStateParallelization RndStatePrimitive type RndState = RndStateList newtype RndT m a = RndT@@ -124,14 +128,12 @@ replaceSeedM :: Monad m => RndStatePrimitive -> RndT m () replaceSeedM s = RndT $ state $ replaceSeedM s where- replaceSeedM newState (RndStateListParallel _) = ((),RndStateListParallel newState)- replaceSeedM newState (RndStateListSequencial _) = ((),RndStateListSequencial newState)+ replaceSeedM newState (RndStateList p _) = ((),RndStateList p newState) addSeedM :: Monad m => RndStatePrimitive -> RndT m () addSeedM s = RndT $ state $ addSeedM s where- addSeedM x (RndStateListSequencial y) = ((),RndStateListSequencial (x ++ y))- addSeedM x (RndStateListParallel y) = ((),RndStateListParallel (x ++ y))+ addSeedM x (RndStateList p y) = ((),RndStateList p (x ++ y)) getRandomM :: Monad m => Integer -> RndT m Integer@@ -145,3 +147,18 @@ runRndT :: RndState -> RndT m a -> m (a, RndState) runRndT rnd m = runStateT (unRndT m) rnd++withOneElementPrecalculated (x:xs@(y:_)) = par (force y) x :+ withOneElementPrecalculated xs++seedFromBytestrings :: [ByS.ByteString] -> RndStatePrimitive+seedFromBytestrings list = [BS.bitStringLazy $ ByLS.fromChunks list]++seedFromBytestringsThreaded :: [ByS.ByteString] -> RndStatePrimitive+seedFromBytestringsThreaded list = [BS.bitStringLazy $ ByLS.fromChunks $ withOneElementPrecalculated list]++seedFromBytestringsM :: Monad m => [ByS.ByteString] -> RndT m RndStatePrimitive+seedFromBytestringsM list = RndT $ state $ getSeed list+ where+ getSeed list st@(RndStateList RndStatePrecalculate _) = (seedFromBytestringsThreaded list, st)+ getSeed list st@(RndStateList _ _) = (seedFromBytestrings list, st)
Test/Tests.hs view
@@ -1,4 +1,4 @@-import Crypto.RandomMonad (runRndT, getRandomM, RndStateList(RndStateListSequencial, RndStateListParallel), getRandomByteStringM)+import Crypto.RandomMonad (runRndT, getRandomM, RndStateList(..), getRandomByteStringM, RndStateParallelization(..)) import Control.Monad.ST (runST) import Test.QuickCheck@@ -9,8 +9,9 @@ prop_parallelEquals1 = do let lists = [BiS.bitStringLazy $ LC8.pack $ Prelude.concat $ Prelude.repeat "Hej, jag loopar här", BiS.bitStringLazy $ LC8.pack $ Prelude.concat $ Prelude.repeat "Hej, jag loopar också här"]- (first, _) = runST $ runRndT (RndStateListSequencial lists) $ getRandomByteStringM 9001- (second, _) = runST $ runRndT (RndStateListParallel lists) $ getRandomByteStringM 9001- in first == second+ (first, _) = runST $ runRndT (RndStateList RndStateSeq lists) $ getRandomByteStringM 9001+ (second, _) = runST $ runRndT (RndStateList RndStateParallel lists) $ getRandomByteStringM 9001+ (third, _) = runST $ runRndT (RndStateList RndStatePrecalculate lists) $ getRandomByteStringM 9001+ in first == second && second == third main = exitWith $ if prop_parallelEquals1 then ExitSuccess else ExitFailure 1