random-source (empty) → 0.3
raw patch · 13 files changed
+1366/−0 lines, 13 filesdep +basedep +flexible-defaultsdep +mersenne-random-pure64setup-changed
Dependencies added: base, flexible-defaults, mersenne-random-pure64, mtl, mwc-random, random, stateref, syb, template-haskell
Files
- Setup.lhs +5/−0
- random-source.cabal +80/−0
- src/Data/Random/Internal/Prim.hs +48/−0
- src/Data/Random/Internal/Source.hs +142/−0
- src/Data/Random/Internal/TH.hs +497/−0
- src/Data/Random/Internal/Words.hs +128/−0
- src/Data/Random/Source.hs +58/−0
- src/Data/Random/Source/DevRandom.hs +49/−0
- src/Data/Random/Source/IO.hs +35/−0
- src/Data/Random/Source/MWC.hs +39/−0
- src/Data/Random/Source/PureMT.hs +136/−0
- src/Data/Random/Source/Std.hs +20/−0
- src/Data/Random/Source/StdGen.hs +129/−0
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ random-source.cabal view
@@ -0,0 +1,80 @@+name: random-source+version: 0.3+stability: provisional++cabal-version: >= 1.6+build-type: Simple++author: James Cook <james.cook@usma.edu>+maintainer: James Cook <james.cook@usma.edu>+license: PublicDomain+homepage: https://github.com/mokus0/random-fu++category: Math+synopsis: Generic basis for random number generators+description: Random number generation based on entropy sources+ able to produce a small but well-defined set of+ primitive variates. Also includes facilities for+ \"completing\" partial implementations, making it+ easy to define new entropy sources in a way that+ is naturally forward-compatible.++tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.1, + GHC == 6.12.3, GHC == 7.0.1, GHC == 7.0.2++source-repository head+ type: git+ location: https://github.com/mokus0/random-fu.git+ subdir: random-source++Flag splitBase+ Description: base-4 and above do not include syb++Flag mtl2+ Description: mtl-2 has State, etc., as "type" rather than "newtype"++Library+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Data.Random.Source+ Data.Random.Source.IO+ Data.Random.Source.PureMT+ Data.Random.Source.Std+ Data.Random.Source.StdGen+ Data.Random.Internal.Words+ Data.Random.Internal.Source+ other-modules: Data.Random.Internal.Prim+ Data.Random.Internal.TH+ + if impl(ghc >= 6.10)+ -- mwc-random depends on vector, which doesn't build on GHC < 6.10.+ -- I considered breaking this module out into another package, but I+ -- think this is sufficient; anyone compiling something which wants+ -- this module has pretty much no hope of working on earlier GHCs anyway,+ -- because the mwc-random library won't have built successfully.+ -- And if they want to get their hands dirty fixing that, altering+ -- this cabal file is hardly any additional effort.+ exposed-modules: Data.Random.Source.MWC+ build-depends: mwc-random+ + if flag(mtl2)+ build-depends: mtl == 2.*+ cpp-options: -DMTL2+ else+ build-depends: mtl == 1.*+ + if flag(splitBase)+ build-depends: base >= 4 && <5, syb+ else+ build-depends: base >= 3 && <4+ + build-depends: flexible-defaults,+ mersenne-random-pure64,+ random,+ stateref >= 0.3 && < 0.4,+ template-haskell++ if os(Windows)+ cpp-options: -Dwindows+ else+ exposed-modules: Data.Random.Source.DevRandom
+ src/Data/Random/Internal/Prim.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GADTs, RankNTypes, DeriveDataTypeable #-}+-- |This is an internal interface to support the 'RVar' abstraction. It+-- reifies the operations provided by both MonadRandom and RandomSource in a+-- uniform and efficient way, as functions of type @Prim a -> m a@.+module Data.Random.Internal.Prim (Prim(..)) where++import Data.Word+import Data.Typeable++-- |A 'Prompt' GADT describing a request for a primitive random variate.+-- Random variable definitions will request their entropy via these prompts,+-- and entropy sources will satisfy those requests. The functions in+-- "Data.Random.Internal.TH" extend incomplete entropy-source definitions+-- to complete ones, essentially defining a very flexible +-- implementation-defaulting system.+-- +-- Some possible future additions:+-- PrimFloat :: Prim Float+-- PrimInt :: Prim Int+-- PrimPair :: Prim a -> Prim b -> Prim (a :*: b)+-- PrimNormal :: Prim Double+-- PrimChoice :: [(Double :*: a)] -> Prim a+-- PrimBytes :: !Int -> Prim ByteString+--+-- Unfortunately, I cannot get Haddock to accept my comments about the +-- data constructors, but hopefully they should be reasonably self-explanatory.+data Prim a where+ -- An unsigned byte, uniformly distributed from 0 to 0xff+ PrimWord8 :: Prim Word8+ -- An unsigned 16-bit word, uniformly distributed from 0 to 0xffff+ PrimWord16 :: Prim Word16+ -- An unsigned 32-bit word, uniformly distributed from 0 to 0xffffffff+ PrimWord32 :: Prim Word32+ -- An unsigned 64-bit word, uniformly distributed from 0 to 0xffffffffffffffff+ PrimWord64 :: Prim Word64+ -- A double-precision float U, uniformly distributed 0 <= U < 1+ PrimDouble :: Prim Double+ -- A uniformly distributed 'Integer' 0 <= U < 256^n+ PrimNByteInteger :: !Int -> Prim Integer+ deriving (Typeable)++instance Show (Prim a) where+ showsPrec _p PrimWord8 = showString "PrimWord8"+ showsPrec _p PrimWord16 = showString "PrimWord16"+ showsPrec _p PrimWord32 = showString "PrimWord32"+ showsPrec _p PrimWord64 = showString "PrimWord64"+ showsPrec _p PrimDouble = showString "PrimDouble"+ showsPrec p (PrimNByteInteger n) = showParen (p > 10) (showString "PrimNByteInteger " . showsPrec 11 n)
+ src/Data/Random/Internal/Source.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE+ TemplateHaskell, GADTs, RankNTypes,+ MultiParamTypeClasses, FlexibleInstances, FlexibleContexts+ #-}++module Data.Random.Internal.Source+ ( Prim(..)+ , MonadRandom(..)+ , RandomSource(..)+ , GetPrim(..)+ ) where++import Data.Random.Internal.Prim+import Data.Word++-- |A typeclass for monads with a chosen source of entropy. For example,+-- 'RVar' is such a monad - the source from which it is (eventually) sampled+-- is the only source from which a random variable is permitted to draw, so+-- when directly requesting entropy for a random variable these functions+-- are used.+--+-- Minimum implementation is either the internal 'getRandomPrim' or all+-- other functions. Additionally, this class's interface is subject to +-- extension at any time, so it is very, very strongly recommended that+-- the 'monadRandom' Template Haskell function be used to implement this +-- function rather than directly implementing it. That function takes care+-- of choosing default implementations for any missing functions; as long as+-- at least one function is implemented, it will derive sensible +-- implementations of all others.+-- +-- To use 'monadRandom', just wrap your instance declaration as follows (and+-- enable the TemplateHaskell and GADTs language extensions):+--+-- > $(monadRandom [d|+-- > instance MonadRandom FooM where+-- > getRandomDouble = return pi+-- > getRandomWord16 = return 4+-- > {- etc... -}+-- > |])+class Monad m => MonadRandom m where+ -- |Generate a random value corresponding to the specified primitive.+ -- + -- This is an internal interface; use at your own risk. It may change or+ -- disappear at any time.+ getRandomPrim :: Prim t -> m t+ getRandomPrim PrimWord8 = getRandomWord8+ getRandomPrim PrimWord16 = getRandomWord16+ getRandomPrim PrimWord32 = getRandomWord32+ getRandomPrim PrimWord64 = getRandomWord64+ getRandomPrim PrimDouble = getRandomDouble+ getRandomPrim (PrimNByteInteger n) = getRandomNByteInteger n+ + -- |Generate a uniformly distributed random 'Word8'+ getRandomWord8 :: m Word8+ getRandomWord8 = getRandomPrim PrimWord8+ + -- |Generate a uniformly distributed random 'Word16'+ getRandomWord16 :: m Word16+ getRandomWord16 = getRandomPrim PrimWord16+ + -- |Generate a uniformly distributed random 'Word32'+ getRandomWord32 :: m Word32+ getRandomWord32 = getRandomPrim PrimWord32+ + -- |Generate a uniformly distributed random 'Word64'+ getRandomWord64 :: m Word64+ getRandomWord64 = getRandomPrim PrimWord64+ + -- |Generate a uniformly distributed random 'Double' in the range 0 <= U < 1+ getRandomDouble :: m Double+ getRandomDouble = getRandomPrim PrimDouble+ + -- |Generate a uniformly distributed random 'Integer' in the range 0 <= U < 256^n+ getRandomNByteInteger :: MonadRandom m => Int -> m Integer+ getRandomNByteInteger n = getRandomPrim (PrimNByteInteger n)+++-- |A source of entropy which can be used in the given monad.+-- +-- See also 'MonadRandom'.+-- +-- Minimum implementation is either the internal 'getRandomPrimFrom' or all+-- other functions. Additionally, this class's interface is subject to +-- extension at any time, so it is very, very strongly recommended that+-- the 'randomSource' Template Haskell function be used to implement this +-- function rather than directly implementing it. That function takes care+-- of choosing default implementations for any missing functions; as long as+-- at least one function is implemented, it will derive sensible +-- implementations of all others.+-- +-- To use 'randomSource', just wrap your instance declaration as follows (and+-- enable the TemplateHaskell, MultiParamTypeClasses and GADTs language+-- extensions, as well as any others required by your instances, such as+-- FlexibleInstances):+--+-- > $(randomSource [d|+-- > instance RandomSource FooM Bar where+-- > {- at least one RandomSource function... -}+-- > |])+class Monad m => RandomSource m s where+ -- |Generate a random value corresponding to the specified primitive.+ -- + -- This is an internal interface; use at your own risk. It may change or+ -- disappear at any time.+ getRandomPrimFrom :: s -> Prim t -> m t+ getRandomPrimFrom src PrimWord8 = getRandomWord8From src+ getRandomPrimFrom src PrimWord16 = getRandomWord16From src+ getRandomPrimFrom src PrimWord32 = getRandomWord32From src+ getRandomPrimFrom src PrimWord64 = getRandomWord64From src+ getRandomPrimFrom src PrimDouble = getRandomDoubleFrom src+ getRandomPrimFrom src (PrimNByteInteger n) = getRandomNByteIntegerFrom src n+ + + -- |Generate a uniformly distributed random 'Word8'+ getRandomWord8From :: s -> m Word8+ getRandomWord8From src = getRandomPrimFrom src PrimWord8+ + -- |Generate a uniformly distributed random 'Word16'+ getRandomWord16From :: s -> m Word16+ getRandomWord16From src = getRandomPrimFrom src PrimWord16+ + -- |Generate a uniformly distributed random 'Word32'+ getRandomWord32From :: s -> m Word32+ getRandomWord32From src = getRandomPrimFrom src PrimWord32+ + -- |Generate a uniformly distributed random 'Word64'+ getRandomWord64From :: s -> m Word64+ getRandomWord64From src = getRandomPrimFrom src PrimWord64+ + -- |Generate a uniformly distributed random 'Double' in the range 0 <= U < 1+ getRandomDoubleFrom :: s -> m Double+ getRandomDoubleFrom src = getRandomPrimFrom src PrimDouble+ + -- |Generate a uniformly distributed random 'Integer' in the range 0 <= U < 256^n+ getRandomNByteIntegerFrom :: s -> Int -> m Integer+ getRandomNByteIntegerFrom src n = getRandomPrimFrom src (PrimNByteInteger n)++-- |This type provides a way to define a 'RandomSource' for a monad without actually+-- having to declare an instance.+newtype GetPrim m = GetPrim (forall t. Prim t -> m t)+instance Monad m => RandomSource m (GetPrim m) where+ getRandomPrimFrom (GetPrim f) = f
+ src/Data/Random/Internal/TH.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE TemplateHaskell, GADTs #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-missing-signatures #-}+module Data.Random.Internal.TH (monadRandom, randomSource) where++import Data.Bits+import Data.Generics+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Random.Internal.Source (Prim(..), MonadRandom(..), RandomSource(..))+import Data.Random.Internal.Words+import Language.Haskell.TH+import qualified Language.Haskell.TH.FlexibleDefaults as FD++import Control.Monad.Reader++data Method+ = GetPrim+ | GetWord8+ | GetWord16+ | GetWord32+ | GetWord64+ | GetDouble+ | GetNByteInteger+ deriving (Eq, Ord, Enum, Bounded, Read, Show)++allMethods :: [Method]+allMethods = [minBound .. maxBound]++data Context+ = Generic+ | RandomSource+ | MonadRandom+ deriving (Eq, Ord, Enum, Bounded, Read, Show)++methodNameBase :: Context -> Method -> String+methodNameBase c n = nameBase (methodName c n)++methodName :: Context -> Method -> Name+methodName Generic GetPrim = mkName "getPrim"+methodName Generic GetWord8 = mkName "getWord8"+methodName Generic GetWord16 = mkName "getWord16"+methodName Generic GetWord32 = mkName "getWord32"+methodName Generic GetWord64 = mkName "getWord64"+methodName Generic GetDouble = mkName "getDouble"+methodName Generic GetNByteInteger = mkName "getNByteInteger"+methodName RandomSource GetPrim = 'getRandomPrimFrom+methodName RandomSource GetWord8 = 'getRandomWord8From+methodName RandomSource GetWord16 = 'getRandomWord16From+methodName RandomSource GetWord32 = 'getRandomWord32From+methodName RandomSource GetWord64 = 'getRandomWord64From+methodName RandomSource GetDouble = 'getRandomDoubleFrom+methodName RandomSource GetNByteInteger = 'getRandomNByteIntegerFrom+methodName MonadRandom GetPrim = 'getRandomPrim+methodName MonadRandom GetWord8 = 'getRandomWord8+methodName MonadRandom GetWord16 = 'getRandomWord16+methodName MonadRandom GetWord32 = 'getRandomWord32+methodName MonadRandom GetWord64 = 'getRandomWord64+methodName MonadRandom GetDouble = 'getRandomDouble+methodName MonadRandom GetNByteInteger = 'getRandomNByteInteger++isMethodName :: Context -> Name -> Bool+isMethodName c n = isJust (nameToMethod c n)++nameToMethod :: Context -> Name -> Maybe Method+nameToMethod c name+ = lookup name+ [ (n, m) + | m <- allMethods+ , let n = methodName c m+ ]+++-- 'Context'-sensitive version of the FlexibleDefaults DSL+scoreBy :: (a -> b) -> ReaderT Context (FD.Defaults a) t -> ReaderT Context (FD.Defaults b) t+scoreBy f = mapReaderT (FD.scoreBy f)++method :: Method -> ReaderT Context (FD.Function s) t -> ReaderT Context (FD.Defaults s) t+method m f = do+ c <- ask+ mapReaderT (FD.function (methodNameBase c m)) f++requireMethod :: Method -> ReaderT Context (FD.Defaults s) ()+requireMethod m = do+ c <- ask+ lift (FD.requireFunction (methodNameBase c m))++implementation :: ReaderT Context (FD.Implementation s) (Q [Dec]) -> ReaderT Context (FD.Function s) ()+implementation = mapReaderT FD.implementation++score :: s -> ReaderT Context (FD.Implementation s) ()+score = lift . FD.score++cost :: Num s => s -> ReaderT Context (FD.Implementation s) ()+cost = lift . FD.cost++dependsOn :: Method -> ReaderT Context (FD.Implementation s) ()+dependsOn m = do+ c <- ask+ lift (FD.dependsOn (methodNameBase c m))++inline :: ReaderT Context (FD.Implementation s) ()+inline = lift FD.inline++noinline :: ReaderT Context (FD.Implementation s) ()+noinline = lift FD.noinline++replace :: (a -> Maybe a) -> (a -> a)+replace = ap fromMaybe++replaceMethodName :: (Method -> Name) -> Name -> Name+replaceMethodName f = replace (fmap f . nameToMethod Generic)++changeContext :: Context -> Context -> Name -> Name+changeContext c1 c2 = replace (fmap (methodName c2) . nameToMethod c1)++-- map all occurrences of generic method names to the proper local ones+-- and introduce a 'src' parameter where needed if the Context is RandomSource+specialize :: Monad m => Q [Dec] -> ReaderT Context m (Q [Dec])+specialize decQ = do+ c <- ask+ let specializeDec = everywhere (mkT (changeContext Generic c))+ if c == RandomSource+ then return $ do+ src <- newName "_src"+ decs <- decQ+ return (map (addSrcParam src) . specializeDec $ decs)+ else return (fmap specializeDec decQ)++stripTypeSigs :: Q [Dec] -> Q [Dec]+stripTypeSigs = fmap (filter (not . isSig))+ where isSig SigD{} = True; isSig _ = False++addSrcParam :: Name -> Dec -> Dec+addSrcParam src+ = everywhere (mkT expandDecs) + . everywhere (mkT expandExps)+ where+ srcP = VarP src+ srcE = VarE src+ + expandDecs (ValD (VarP n) body decs)+ | isMethodName RandomSource n+ = FunD n [Clause [srcP] body decs]+ expandDecs (FunD n clauses)+ | isMethodName RandomSource n+ = FunD n [Clause (srcP : ps) body decs | Clause ps body decs <- clauses]+ + expandDecs other = other+ + expandExps e@(VarE n)+ | isMethodName RandomSource n = AppE e srcE+ expandExps other = other++-- dummy expressions which will be remapped by 'specialize'+dummy :: Method -> ExpQ+dummy = return . VarE . methodName Generic++getPrim, getWord8, getWord16, + getWord32, getWord64, getDouble, + getNByteInteger :: ExpQ+getPrim = dummy GetPrim+getWord8 = dummy GetWord8+getWord16 = dummy GetWord16+getWord32 = dummy GetWord32+getWord64 = dummy GetWord64+getDouble = dummy GetDouble+getNByteInteger = dummy GetNByteInteger++intIs64 :: Bool+intIs64 = toInteger (maxBound :: Int) > 2^32++-- The defaulting rules for RandomSource and MonadRandom. Costs are rates of+-- entropy waste (bits discarded per bit requested) plus the occasional ad-hoc+-- penalty where it seems appropriate.++-- TODO: figure out a clean way to break these up for individual testing.+-- Also analyze to see which of these can never be selected (I suspect that set is non-empty)+defaults :: Context -> FD.Defaults (Sum Double) ()+defaults = runReaderT $+ scoreBy Sum $ do+ method GetPrim $ do+ implementation $ do+ mapM_ dependsOn (allMethods \\ [GetPrim])+ + -- GHC 6 requires type signatures for GADT matches, even+ -- inside [d||]. This code is evaluated at more than one type, though,+ -- and at its eventual splice site the signature actually isn't even allowed.+ -- So, there's a dummy signature here which is immediately stripped out.+ specialize . stripTypeSigs $+ [d| getPrim :: Prim a -> m a+ getPrim PrimWord8 = $getWord8+ getPrim PrimWord16 = $getWord16+ getPrim PrimWord32 = $getWord32+ getPrim PrimWord64 = $getWord64+ getPrim PrimDouble = $getDouble+ getPrim (PrimNByteInteger n) = $getNByteInteger n+ |]+ + scoreBy (/8) $+ method GetWord8 $ do+ implementation $ do+ dependsOn GetPrim+ specialize [d| getWord8 = $getPrim PrimWord8 |]+ + implementation $ do+ cost 1+ dependsOn GetNByteInteger+ specialize [d| getWord8 = liftM fromInteger ($getNByteInteger 1) |]+ + implementation $ do+ cost 8+ dependsOn GetWord16+ specialize [d| getWord8 = liftM fromIntegral $getWord16 |]+ + implementation $ do+ cost 24+ dependsOn GetWord32+ specialize [d| getWord8 = liftM fromIntegral $getWord32 |]+ + implementation $ do+ cost 56+ dependsOn GetWord64+ specialize [d| getWord8 = liftM fromIntegral $getWord64 |]+ + implementation $ do+ cost 64+ dependsOn GetDouble+ specialize [d| getWord8 = liftM (truncate . (256*)) $getDouble |]+ + scoreBy (/16) $+ method GetWord16 $ do+ implementation $ do+ dependsOn GetPrim+ specialize [d| getWord16 = $getPrim PrimWord16 |]+ + implementation $ do+ cost 1+ dependsOn GetNByteInteger+ specialize [d| getWord16 = liftM fromInteger ($getNByteInteger 2) |]+ + implementation $ do+ dependsOn GetWord8+ specialize + [d|+ getWord16 = do+ a <- $getWord8+ b <- $getWord8+ return (buildWord16 a b)+ |]+ + implementation $ do+ cost 16+ dependsOn GetWord32+ specialize [d| getWord16 = liftM fromIntegral $getWord32 |]+ + implementation $ do+ cost 48+ dependsOn GetWord64+ specialize [d| getWord16 = liftM fromIntegral $getWord64 |]+ + implementation $ do+ cost 64+ dependsOn GetDouble+ specialize [d| getWord16 = liftM (truncate . (65536*)) $getDouble |]+ + scoreBy (/32) $+ method GetWord32 $ do+ implementation $ do+ dependsOn GetPrim+ specialize [d| getWord32 = $getPrim PrimWord32 |]+ + implementation $ do+ cost 1+ dependsOn GetNByteInteger+ specialize [d| getWord32 = liftM fromInteger ($getNByteInteger 4) |]+ + implementation $ do+ cost 0.1+ dependsOn GetWord8+ specialize + [d|+ getWord32 = do+ a <- $getWord8+ b <- $getWord8+ c <- $getWord8+ d <- $getWord8+ return (buildWord32 a b c d)+ |]+ + implementation $ do+ dependsOn GetWord16+ specialize + [d|+ getWord32 = do+ a <- $getWord16+ b <- $getWord16+ return (buildWord32' a b)+ |]+ + implementation $ do+ cost 32+ dependsOn GetWord64+ specialize [d| getWord32 = liftM fromIntegral $getWord64 |]+ + implementation $ do+ cost 64+ dependsOn GetDouble+ specialize [d| getWord32 = liftM (truncate . (4294967296*)) $getDouble |]+ + scoreBy (/64) $+ method GetWord64 $ do+ implementation $ do+ dependsOn GetPrim+ specialize [d| getWord64 = $getPrim PrimWord64 |]+ + implementation $ do+ cost 1+ dependsOn GetNByteInteger+ specialize [d| getWord64 = liftM fromInteger ($getNByteInteger 8) |]+ + implementation $ do+ cost 0.2+ dependsOn GetWord8+ specialize + [d|+ getWord64 = do+ a <- $getWord8+ b <- $getWord8+ c <- $getWord8+ d <- $getWord8+ e <- $getWord8+ f <- $getWord8+ g <- $getWord8+ h <- $getWord8+ return (buildWord64 a b c d e f g h)+ |]+ + implementation $ do+ cost 0.1+ dependsOn GetWord16+ specialize + [d|+ getWord64 = do+ a <- $getWord16+ b <- $getWord16+ c <- $getWord16+ d <- $getWord16+ return (buildWord64' a b c d)+ |]+ + implementation $ do+ dependsOn GetWord32+ specialize + [d|+ getWord64 = do+ a <- $getWord32+ b <- $getWord32+ return (buildWord64'' a b)+ |]+ + scoreBy (/52) $+ method GetDouble $ do+ implementation $ do+ dependsOn GetPrim+ specialize [d| getDouble = $getPrim PrimDouble |]+ + implementation $ do+ cost 12+ dependsOn GetWord64+ specialize + [d|+ getDouble = do+ w <- $getWord64+ return (wordToDouble w)+ |]+ + method GetNByteInteger $ do+ implementation $ do+ dependsOn GetPrim+ specialize [d| getNByteInteger n = $getPrim (PrimNByteInteger n) |]+ + implementation $ do+ when intIs64 (cost 1e-2)+ dependsOn GetWord8+ dependsOn GetWord16+ dependsOn GetWord32+ specialize+ [d|+ getNByteInteger 1 = do+ x <- $getWord8+ return $! toInteger x+ getNByteInteger 2 = do+ x <- $getWord16+ return $! toInteger x+ getNByteInteger 4 = do+ x <- $getWord32+ return $! toInteger x+ getNByteInteger np4+ | np4 > 4 = do+ let n = np4 - 4+ x <- $getWord32+ y <- $(dummy GetNByteInteger) n+ return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y+ getNByteInteger np2+ | np2 > 2 = do+ let n = np2 - 2+ x <- $getWord16+ y <- $(dummy GetNByteInteger) n+ return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y+ getNByteInteger _ = return 0+ |]+ + implementation $ do+ when (not intIs64) (cost 1e-2)+ dependsOn GetWord8+ dependsOn GetWord16+ dependsOn GetWord32+ dependsOn GetWord64+ specialize+ [d|+ getNByteInteger 1 = do+ x <- $getWord8+ return $! toInteger x+ getNByteInteger 2 = do+ x <- $getWord16+ return $! toInteger x+ getNByteInteger 4 = do+ x <- $getWord32+ return $! toInteger x+ getNByteInteger 8 = do+ x <- $getWord64+ return $! toInteger x+ getNByteInteger np8+ | np8 > 8 = do+ let n = np8 - 8+ x <- $getWord64+ y <- $(dummy GetNByteInteger) n+ return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y+ getNByteInteger np4+ | np4 > 4 = do+ let n = np4 - 4+ x <- $getWord32+ y <- $(dummy GetNByteInteger) n+ return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y+ getNByteInteger np2+ | np2 > 2 = do+ let n = np2 - 2+ x <- $getWord16+ y <- $(dummy GetNByteInteger) n+ return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y+ getNByteInteger _ = return 0+ |]+ ++-- |Complete a possibly-incomplete 'RandomSource' implementation. It is +-- recommended that this macro be used even if the implementation is currently+-- complete, as the 'RandomSource' class may be extended at any time.+--+-- To use 'randomSource', just wrap your instance declaration as follows (and+-- enable the TemplateHaskell, MultiParamTypeClasses and GADTs language+-- extensions, as well as any others required by your instances, such as+-- FlexibleInstances):+--+-- > $(randomSource [d|+-- > instance RandomSource FooM Bar where+-- > {- at least one RandomSource function... -}+-- > |])+randomSource :: Q [Dec] -> Q [Dec]+randomSource = FD.withDefaults (defaults RandomSource)++-- |Complete a possibly-incomplete 'MonadRandom' implementation. It is +-- recommended that this macro be used even if the implementation is currently+-- complete, as the 'MonadRandom' class may be extended at any time.+--+-- To use 'monadRandom', just wrap your instance declaration as follows (and+-- enable the TemplateHaskell and GADTs language extensions):+--+-- > $(monadRandom [d|+-- > instance MonadRandom FooM where+-- > getRandomDouble = return pi+-- > getRandomWord16 = return 4+-- > {- etc... -}+-- > |])+monadRandom :: Q [Dec] -> Q [Dec]+monadRandom = FD.withDefaults (defaults MonadRandom)++-- -- This is nice in theory, but under GHC 7 it never typechecks; without generalizing the let-bound+-- -- functions, it gets absurd errors like "cannot match 'm Int' with 'IO t'". Probably need+-- -- to mechanically specialize the supplied signature to create a signature for every other+-- -- let-bound function.+-- primFunction :: Q Type -> Q [Dec] -> ExpQ+-- primFunction getPrimType decsQ = do+-- getPrimSig <- sigD (mkName (methodName Generic GetPrim)) getPrimType+-- decs <- decsQ >>= FD.implementDefaults (defaults Generic)+-- f <- getPrim+-- return (LetE (getPrimSig : decs) f)
+ src/Data/Random/Internal/Words.hs view
@@ -0,0 +1,128 @@+{-+ - ``Data/Random/Internal/Words''+ -}++-- |A few little functions I found myself writing inline over and over again.+module Data.Random.Internal.Words where++import Foreign++-- TODO: add a build flag for endianness-invariance, or just find a way+-- to make sure these operations all do the right thing without costing +-- anything extra at runtime++{-# INLINE buildWord16 #-}+-- |Build a word out of 2 bytes. No promises are made regarding the order+-- in which the bytes are stuffed. Note that this means that a 'RandomSource'+-- or 'MonadRandom' making use of the default definition of 'getRandomWord', etc.,+-- may return different random values on different platforms when started +-- with the same seed, depending on the platform's endianness.+buildWord16 :: Word8 -> Word8 -> Word16+buildWord16 b0 b1+ = unsafePerformIO . allocaBytes 2 $ \p -> do+ pokeByteOff p 0 b0+ pokeByteOff p 1 b1+ peek (castPtr p)++{-# INLINE buildWord32 #-}+-- |Build a word out of 4 bytes. No promises are made regarding the order+-- in which the bytes are stuffed. Note that this means that a 'RandomSource'+-- or 'MonadRandom' making use of the default definition of 'getRandomWord', etc.,+-- may return different random values on different platforms when started +-- with the same seed, depending on the platform's endianness.+buildWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+buildWord32 b0 b1 b2 b3+ = unsafePerformIO . allocaBytes 4 $ \p -> do+ pokeByteOff p 0 b0+ pokeByteOff p 1 b1+ pokeByteOff p 2 b2+ pokeByteOff p 3 b3+ peek (castPtr p)++{-# INLINE buildWord32' #-}+buildWord32' :: Word16 -> Word16 -> Word32+buildWord32' w0 w1+ = unsafePerformIO . allocaBytes 4 $ \p -> do+ pokeByteOff p 0 w0+ pokeByteOff p 2 w1+ peek (castPtr p)++{-# INLINE buildWord64 #-}+-- |Build a word out of 8 bytes. No promises are made regarding the order+-- in which the bytes are stuffed. Note that this means that a 'RandomSource'+-- or 'MonadRandom' making use of the default definition of 'getRandomWord', etc.,+-- may return different random values on different platforms when started +-- with the same seed, depending on the platform's endianness.+buildWord64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word64+buildWord64 b0 b1 b2 b3 b4 b5 b6 b7+ = unsafePerformIO . allocaBytes 8 $ \p -> do+ pokeByteOff p 0 b0+ pokeByteOff p 1 b1+ pokeByteOff p 2 b2+ pokeByteOff p 3 b3+ pokeByteOff p 4 b4+ pokeByteOff p 5 b5+ pokeByteOff p 6 b6+ pokeByteOff p 7 b7+ peek (castPtr p)++{-# INLINE buildWord64' #-}+buildWord64' :: Word16 -> Word16 -> Word16 -> Word16 -> Word64+buildWord64' w0 w1 w2 w3+ = unsafePerformIO . allocaBytes 8 $ \p -> do+ pokeByteOff p 0 w0+ pokeByteOff p 2 w1+ pokeByteOff p 4 w2+ pokeByteOff p 6 w3+ peek (castPtr p)++{-# INLINE buildWord64'' #-}+buildWord64'' :: Word32 -> Word32 -> Word64+buildWord64'' w0 w1+ = unsafePerformIO . allocaBytes 8 $ \p -> do+ pokeByteOff p 0 w0+ pokeByteOff p 4 w1+ peek (castPtr p)++{-# INLINE word32ToFloat #-}+-- |Pack the low 23 bits from a 'Word32' into a 'Float' in the range [0,1).+-- Used to convert a 'stdUniform' 'Word32' to a 'stdUniform' 'Double'.+word32ToFloat :: Word32 -> Float+word32ToFloat x = (encodeFloat $! toInteger (x .&. 0x007fffff {- 2^23-1 -} )) $ (-23)++{-# INLINE word32ToFloatWithExcess #-}+-- |Same as word32ToFloat, but also return the unused bits (as the 9+-- least significant bits of a 'Word32')+word32ToFloatWithExcess :: Word32 -> (Float, Word32)+word32ToFloatWithExcess x = (word32ToFloat x, x `shiftR` 23)++{-# INLINE wordToFloat #-}+-- |Pack the low 23 bits from a 'Word64' into a 'Float' in the range [0,1).+-- Used to convert a 'stdUniform' 'Word64' to a 'stdUniform' 'Double'.+wordToFloat :: Word64 -> Float+wordToFloat x = (encodeFloat $! toInteger (x .&. 0x007fffff {- 2^23-1 -} )) $ (-23)++{-# INLINE wordToFloatWithExcess #-}+-- |Same as wordToFloat, but also return the unused bits (as the 41+-- least significant bits of a 'Word64')+wordToFloatWithExcess :: Word64 -> (Float, Word64)+wordToFloatWithExcess x = (wordToFloat x, x `shiftR` 23)++{-# INLINE wordToDouble #-}+-- |Pack the low 52 bits from a 'Word64' into a 'Double' in the range [0,1).+-- Used to convert a 'stdUniform' 'Word64' to a 'stdUniform' 'Double'.+wordToDouble :: Word64 -> Double+wordToDouble x = (encodeFloat $! toInteger (x .&. 0x000fffffffffffff {- 2^52-1 -})) $ (-52)++{-# INLINE word32ToDouble #-}+-- |Pack a 'Word32' into a 'Double' in the range [0,1). Note that a Double's +-- mantissa is 52 bits, so this does not fill all of them.+word32ToDouble :: Word32 -> Double+word32ToDouble x = (encodeFloat $! toInteger x) $ (-32)++{-# INLINE wordToDoubleWithExcess #-}+-- |Same as wordToDouble, but also return the unused bits (as the 12+-- least significant bits of a 'Word64')+wordToDoubleWithExcess :: Word64 -> (Double, Word64)+wordToDoubleWithExcess x = (wordToDouble x, x `shiftR` 52)+
+ src/Data/Random/Source.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE+ MultiParamTypeClasses, FlexibleInstances, TemplateHaskell, GADTs+ #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Random.Source+ ( MonadRandom+ ( getRandomWord8+ , getRandomWord16+ , getRandomWord32+ , getRandomWord64+ , getRandomDouble+ , getRandomNByteInteger+ )+ + , RandomSource+ ( getRandomWord8From+ , getRandomWord16From+ , getRandomWord32From+ , getRandomWord64From+ , getRandomDoubleFrom+ , getRandomNByteIntegerFrom+ )+ + , monadRandom, randomSource+ ) where++import Data.Word++import Data.Random.Internal.Source+import Data.Random.Internal.TH++$(randomSource+ [d| + instance Monad m => RandomSource m (m Word8) where+ getRandomWord8From = id+ |])++$(randomSource+ [d|+ instance Monad m => RandomSource m (m Word16) where+ getRandomWord16From = id+ |])++$(randomSource+ [d|+ instance Monad m => RandomSource m (m Word32) where+ getRandomWord32From = id+ |])++$(randomSource+ [d| instance Monad m => RandomSource m (m Word64) where+ getRandomWord64From = id+ |])++$(randomSource+ [d| instance Monad m => RandomSource m (m Double) where+ getRandomDoubleFrom = id+ |])
+ src/Data/Random/Source/DevRandom.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE+ TemplateHaskell, MultiParamTypeClasses, GADTs+ #-}++module Data.Random.Source.DevRandom + ( DevRandom(..)+ ) where++import Data.Random.Source++import System.IO (openBinaryFile, hGetBuf, Handle, IOMode(..))+import Foreign++-- |On systems that have it, \/dev\/random is a handy-dandy ready-to-use source+-- of nonsense. Keep in mind that on some systems, Linux included, \/dev\/random+-- collects \"real\" entropy, and if you don't have a good source of it, such as+-- special hardware for the purpose or a *lot* of network traffic, it's pretty easy+-- to suck the entropy pool dry with entropy-intensive applications. For many+-- purposes other than cryptography, \/dev\/urandom is preferable because when it+-- runs out of real entropy it'll still churn out pseudorandom data.+data DevRandom = DevRandom | DevURandom+ deriving (Eq, Show)++{-# NOINLINE devRandom #-}+devRandom :: Handle+devRandom = unsafePerformIO (openBinaryFile "/dev/random" ReadMode)+{-# NOINLINE devURandom #-}+devURandom :: Handle+devURandom = unsafePerformIO (openBinaryFile "/dev/urandom" ReadMode)++dev :: DevRandom -> Handle+dev DevRandom = devRandom+dev DevURandom = devURandom++$(randomSource+ [d| instance RandomSource IO DevRandom where+ getRandomWord8From src = allocaBytes 1 $ \buf -> do+ 1 <- hGetBuf (dev src) buf 1+ peek buf+ getRandomWord16From src = allocaBytes 2 $ \buf -> do+ 2 <- hGetBuf (dev src) buf 2+ peek (castPtr buf)+ getRandomWord32From src = allocaBytes 4 $ \buf -> do+ 4 <- hGetBuf (dev src) buf 4+ peek (castPtr buf)+ getRandomWord64From src = allocaBytes 8 $ \buf -> do+ 8 <- hGetBuf (dev src) buf 8+ peek (castPtr buf)+ |])
+ src/Data/Random/Source/IO.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |For convenience, this module defines an instance of 'MonadRandom' for the 'IO' monad.+-- On Windows it uses "Data.Random.Source.MWC" (or "Data.Random.Source.StdGen" on older+-- versions of GHC where the mwc-random package doesn't build) and on other platforms it uses+-- "Data.Random.Source.DevRandom".+module Data.Random.Source.IO () where++import Data.Random.Internal.Source++#ifndef windows++import Data.Random.Source.DevRandom+instance MonadRandom IO where+ getRandomPrim = getRandomPrimFrom DevURandom++#else++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 610++import Data.Random.Source.MWC+import System.Random.MWC++instance MonadRandom IO where+ getRandomPrim = withSystemRandom . (flip getRandomPrimFrom :: Prim t -> Gen RealWorld -> IO t)++#else++import Data.Random.Source.StdGen+instance MonadRandom IO where+ getRandomPrim = getRandomPrimFromStdGenIO+ +#endif++#endif
+ src/Data/Random/Source/MWC.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE+ TemplateHaskell,+ MultiParamTypeClasses,+ FlexibleInstances,+ GADTs+ #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |This module defines the following instances:+-- +-- > instance RandomSource (ST s) (Gen s)+-- > instance RandomSource IO (Gen RealWorld)+module Data.Random.Source.MWC+ ( Gen, RealWorld+ , create, initialize+ , save, restore+ ) where++import Data.Random.Internal.Words+import Data.Random.Source+import System.Random.MWC+import Control.Monad.ST++$(randomSource+ [d| instance RandomSource (ST s) (Gen s) where+ getRandomWord8From = uniform+ getRandomWord16From = uniform+ getRandomWord32From = uniform+ getRandomWord64From = uniform+ getRandomDoubleFrom = fmap wordToDouble . uniform+ |])++$(randomSource+ [d| instance RandomSource IO (Gen RealWorld) where+ getRandomWord8From = uniform+ getRandomWord16From = uniform+ getRandomWord32From = uniform+ getRandomWord64From = uniform+ getRandomDoubleFrom = fmap wordToDouble . uniform+ |])
+ src/Data/Random/Source/PureMT.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, GADTs #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |This module provides functions useful for implementing new 'MonadRandom'+-- and 'RandomSource' instances for state-abstractions containing 'PureMT'+-- values (the pure pseudorandom generator provided by the+-- mersenne-random-pure64 package), as well as instances for some common+-- cases.+-- +-- A 'PureMT' generator is immutable, so 'PureMT' by itself cannot be a +-- 'RandomSource' (if it were, it would always give the same \"random\"+-- values). Some form of mutable state must be used, such as an 'IORef',+-- 'State' monad, etc.. A few default instances are provided by this module+-- along with a more-general function ('getRandomPrimFromMTRef') usable as+-- an implementation for new cases users might need.+module Data.Random.Source.PureMT + ( PureMT, newPureMT, pureMT+ + , getRandomPrimFromMTRef+ ) where++import Control.Monad.State+import qualified Control.Monad.State.Strict as S+import Data.Random.Internal.Source+import Data.Random.Internal.TH+import Data.StateRef+import System.Random.Mersenne.Pure64++{-# INLINE withMTRef #-}+withMTRef :: (Monad m, ModifyRef sr m PureMT) => (PureMT -> (t, PureMT)) -> sr -> m t+withMTRef thing ref = atomicModifyReference ref $ \(!oldMT) -> + case thing oldMT of (!w, !newMT) -> (newMT, w)++{-# INLINE withMTState #-}+withMTState :: MonadState PureMT m => (PureMT -> (t, PureMT)) -> m t+withMTState thing = do+ !mt <- get+ let (!ws, !newMt) = thing mt+ put newMt+ return ws++#ifndef MTL2++$(monadRandom+ [d| instance MonadRandom (State PureMT) |] where+ getRandomWord64 = withMTState randomWord64+ getRandomDouble = withMTState randomDouble+ |])++$(monadRandom+ [d| instance MonadRandom (S.State PureMT) where+ getRandomWord64 = withMTState randomWord64+ getRandomDouble = withMTState randomDouble+ |])++#endif++$(randomSource+ [d| instance (Monad m1, ModifyRef (Ref m2 PureMT) m1 PureMT) => RandomSource m1 (Ref m2 PureMT) where+ getRandomWord64From = withMTRef randomWord64+ getRandomDoubleFrom = withMTRef randomDouble+ |])++$(monadRandom+ [d| instance Monad m => MonadRandom (StateT PureMT m) where+ getRandomWord64 = withMTState randomWord64+ getRandomDouble = withMTState randomDouble+ |])++$(monadRandom+ [d| instance Monad m => MonadRandom (S.StateT PureMT m) where+ getRandomWord64 = withMTState randomWord64+ getRandomDouble = withMTState randomDouble+ |])++$(randomSource+ [d| instance (MonadIO m) => RandomSource m (IORef PureMT) where+ getRandomWord64From = withMTRef randomWord64+ getRandomDoubleFrom = withMTRef randomDouble+ |])++$(randomSource+ [d| instance (Monad m, ModifyRef (STRef s PureMT) m PureMT) => RandomSource m (STRef s PureMT) where+ getRandomWord64From = withMTRef randomWord64+ getRandomDoubleFrom = withMTRef randomDouble+ |])++-- Note that this instance is probably a Bad Idea. STM allows random variables+-- to interact in spooky quantum-esque ways - One transaction can 'retry' until+-- it gets a \"random\" answer it likes, which causes it to selectively consume +-- entropy, biasing the supply from which other random variables will draw.+-- instance (Monad m, ModifyRef (TVar PureMT) m PureMT) => RandomSource m (TVar PureMT) where+-- {-# SPECIALIZE instance RandomSource IO (TVar PureMT) #-}+-- {-# SPECIALIZE instance RandomSource STM (TVar PureMT) #-}+-- getRandomPrimFrom = getRandomPrimFromMTRef+++-- |Given a mutable reference to a 'PureMT' generator, we can implement+-- 'RandomSource' for it in any monad in which the reference can be modified.+-- +-- Typically this would be used to define a new 'RandomSource' instance for+-- some new reference type or new monad in which an existing reference type+-- can be modified atomically. As an example, the following instance could+-- be used to describe how 'IORef' 'PureMT' can be a 'RandomSource' in the+-- 'IO' monad:+-- +-- > instance RandomSource IO (IORef PureMT) where+-- > supportedPrimsFrom _ _ = True+-- > getSupportedRandomPrimFrom = getRandomPrimFromMTRef+-- +-- (note that there is actually a more general instance declared already+-- covering this as a a special case, so there's no need to repeat this+-- declaration anywhere)+-- +-- Example usage (using some functions from "Data.Random" in the random-fu +-- package):+-- +-- > main = do+-- > src <- newIORef (pureMT 1234) -- OR: newPureMT >>= newIORef+-- > x <- runRVar (uniform 0 100) src :: IO Double+-- > print x+getRandomPrimFromMTRef :: ModifyRef sr m PureMT => sr -> Prim a -> m a+getRandomPrimFromMTRef ref+ = atomicModifyReference' ref + . runState + . getRandomPrim++atomicModifyReference' :: ModifyRef sr m a => sr -> (a -> (b, a)) -> m b+atomicModifyReference' ref getR =+ atomicModifyReference ref (swap' . getR)+ where swap' (!a,!b) = (b,a)
+ src/Data/Random/Source/Std.hs view
@@ -0,0 +1,20 @@+{-+ - ``Data/Random/Source/Std''+ -}+{-# LANGUAGE+ MultiParamTypeClasses, FlexibleInstances+ #-}++module Data.Random.Source.Std where++import Data.Random.Internal.Source++-- |A token representing the \"standard\" entropy source in a 'MonadRandom'+-- monad. Its sole purpose is to make the following true (when the types check):+--+-- > runRVar x StdRandom === sampleRVar+data StdRandom = StdRandom++instance MonadRandom m => RandomSource m StdRandom where+ {-SPECIALIZE instance MonadRandom m => RandomSource m StdRandom -}+ getRandomPrimFrom StdRandom = getRandomPrim
+ src/Data/Random/Source/StdGen.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE+ CPP,+ MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GADTs,+ BangPatterns, RankNTypes,+ ScopedTypeVariables+ #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |This module provides functions useful for implementing new 'MonadRandom'+-- and 'RandomSource' instances for state-abstractions containing 'StdGen'+-- values (the pure pseudorandom generator provided by the System.Random+-- module in the \"random\" package), as well as instances for some common+-- cases.+module Data.Random.Source.StdGen+ ( StdGen+ , mkStdGen+ , newStdGen+ + , getRandomPrimFromStdGenIO+ , getRandomPrimFromRandomGenRef+ , getRandomPrimFromRandomGenState+ ) where++import Data.Random.Internal.Source+import System.Random+import Control.Monad.State+import qualified Control.Monad.ST.Strict as S+import qualified Control.Monad.State.Strict as S+import Data.StateRef+import Data.Word+++instance (Monad m1, ModifyRef (Ref m2 StdGen) m1 StdGen) => RandomSource m1 (Ref m2 StdGen) where+ getRandomPrimFrom = getRandomPrimFromRandomGenRef++instance (Monad m, ModifyRef (IORef StdGen) m StdGen) => RandomSource m (IORef StdGen) where+ {-# SPECIALIZE instance RandomSource IO (IORef StdGen) #-}+ getRandomPrimFrom = getRandomPrimFromRandomGenRef++-- Note that this instance is probably a Bad Idea. STM allows random variables+-- to interact in spooky quantum-esque ways - One transaction can 'retry' until+-- it gets a \"random\" answer it likes, which causes it to selectively consume +-- entropy, biasing the supply from which other random variables will draw.+-- instance (Monad m, ModifyRef (TVar StdGen) m StdGen) => RandomSource m (TVar StdGen) where+-- {-# SPECIALIZE instance RandomSource IO (TVar StdGen) #-}+-- {-# SPECIALIZE instance RandomSource STM (TVar StdGen) #-}+-- supportedPrimsFrom _ _ = True+-- getSupportedRandomPrimFrom = getRandomPrimFromRandomGenRef++instance (Monad m, ModifyRef (STRef s StdGen) m StdGen) => RandomSource m (STRef s StdGen) where+ {-# SPECIALIZE instance RandomSource (ST s) (STRef s StdGen) #-}+ {-# SPECIALIZE instance RandomSource (S.ST s) (STRef s StdGen) #-}+ getRandomPrimFrom = getRandomPrimFromRandomGenRef++getRandomPrimFromStdGenIO :: Prim a -> IO a+getRandomPrimFromStdGenIO + = getStdRandom+ . runState+ . getRandomPrim++-- |Given a mutable reference to a 'RandomGen' generator, we can make a+-- 'RandomSource' usable in any monad in which the reference can be modified.+-- +-- See "Data.Random.Source.PureMT".'getRandomPrimFromMTRef' for more detailed+-- usage hints - this function serves exactly the same purpose except for a+-- 'StdGen' generator instead of a 'PureMT' generator.+getRandomPrimFromRandomGenRef :: (Monad m, ModifyRef sr m g, RandomGen g) =>+ sr -> Prim a -> m a+getRandomPrimFromRandomGenRef ref + = atomicModifyReference' ref + . runState + . getRandomPrimFromRandomGenState++atomicModifyReference' :: ModifyRef sr m a => sr -> (a -> (b, a)) -> m b+atomicModifyReference' ref getR =+ atomicModifyReference ref (swap' . getR)+ where swap' (!a,!b) = (b,a)+++-- |Similarly, @getRandomWordFromRandomGenState x@ can be used in any \"state\"+-- monad in the mtl sense whose state is a 'RandomGen' generator.+-- Additionally, the standard mtl state monads have 'MonadRandom' instances+-- which do precisely that, allowing an easy conversion of 'RVar's and+-- other 'Distribution' instances to \"pure\" random variables.+-- +-- Again, see "Data.Random.Source.PureMT".'getRandomPrimFromMTState' for more+-- detailed usage hints - this function serves exactly the same purpose except +-- for a 'StdGen' generator instead of a 'PureMT' generator.+{-# SPECIALIZE getRandomPrimFromRandomGenState :: Prim a -> State StdGen a #-}+{-# SPECIALIZE getRandomPrimFromRandomGenState :: Monad m => Prim a -> StateT StdGen m a #-}+getRandomPrimFromRandomGenState :: forall g m a. (RandomGen g, MonadState g m) => Prim a -> m a+getRandomPrimFromRandomGenState = genPrim+ where + {-# INLINE genPrim #-}+ genPrim :: forall t. Prim t -> m t+ genPrim PrimWord8 = getThing (randomR (0, 0xff)) (fromIntegral :: Int -> Word8)+ genPrim PrimWord16 = getThing (randomR (0, 0xffff)) (fromIntegral :: Int -> Word16)+ genPrim PrimWord32 = getThing (randomR (0, 0xffffffff)) (fromInteger)+ genPrim PrimWord64 = getThing (randomR (0, 0xffffffffffffffff)) (fromInteger)+ genPrim PrimDouble = getThing (randomR (0, 0x000fffffffffffff)) (flip encodeFloat (-52))+ {- not using the Random Double instance for 2 reasons. 1st, it only generates 32 bits of entropy, when + a [0,1) Double has room for 52. Second, it appears there's a bug where it can actually generate a + negative number in the case where randomIvalInteger returns minBound::Int32. -}+-- genPrim PrimDouble = getThing (randomR (0, 1.0)) (id)+ genPrim (PrimNByteInteger n) = getThing (randomR (0, iterate (*256) 1 !! n)) id+ + {-# INLINE getThing #-}+ getThing :: forall b t. (g -> (b, g)) -> (b -> t) -> m t+ getThing thing f = do+ !oldGen <- get+ case thing oldGen of+ (!i,!newGen) -> do+ put newGen+ return (f $! i)++#ifndef MTL2+instance MonadRandom (State StdGen) where+ getRandomPrim = getRandomPrimFromRandomGenState++instance MonadRandom (S.State StdGen) where+ getRandomPrim = getRandomPrimFromRandomGenState+#endif++instance Monad m => MonadRandom (StateT StdGen m) where+ getRandomPrim = getRandomPrimFromRandomGenState++instance Monad m => MonadRandom (S.StateT StdGen m) where+ getRandomPrim = getRandomPrimFromRandomGenState+