diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/random-source.cabal b/random-source.cabal new file mode 100644 --- /dev/null +++ b/random-source.cabal @@ -0,0 +1,80 @@ +name: random-source +version: 0.3 +stability: provisional + +cabal-version: >= 1.6 +build-type: Simple + +author: James Cook +maintainer: James Cook +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 diff --git a/src/Data/Random/Internal/Prim.hs b/src/Data/Random/Internal/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Internal/Prim.hs @@ -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) diff --git a/src/Data/Random/Internal/Source.hs b/src/Data/Random/Internal/Source.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Internal/Source.hs @@ -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 diff --git a/src/Data/Random/Internal/TH.hs b/src/Data/Random/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Internal/TH.hs @@ -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) diff --git a/src/Data/Random/Internal/Words.hs b/src/Data/Random/Internal/Words.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Internal/Words.hs @@ -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) + diff --git a/src/Data/Random/Source.hs b/src/Data/Random/Source.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source.hs @@ -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 + |]) diff --git a/src/Data/Random/Source/DevRandom.hs b/src/Data/Random/Source/DevRandom.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/DevRandom.hs @@ -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) + |]) diff --git a/src/Data/Random/Source/IO.hs b/src/Data/Random/Source/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/IO.hs @@ -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 diff --git a/src/Data/Random/Source/MWC.hs b/src/Data/Random/Source/MWC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/MWC.hs @@ -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 + |]) diff --git a/src/Data/Random/Source/PureMT.hs b/src/Data/Random/Source/PureMT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/PureMT.hs @@ -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) diff --git a/src/Data/Random/Source/Std.hs b/src/Data/Random/Source/Std.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/Std.hs @@ -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 diff --git a/src/Data/Random/Source/StdGen.hs b/src/Data/Random/Source/StdGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/StdGen.hs @@ -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 +