random-source 0.3.0.4 → 0.3.0.5
raw patch · 15 files changed
+827/−825 lines, 15 files
Files
- random-source.cabal +7/−5
- src/Data/Random/Internal/Prim.hs +0/−48
- src/Data/Random/Internal/Source.hs +0/−142
- src/Data/Random/Internal/TH.hs +0/−493
- src/Data/Random/Internal/Words.hs +0/−129
- src/Data/Random/Source.hs +2/−2
- src/Data/Random/Source/IO.hs +1/−1
- src/Data/Random/Source/Internal/Prim.hs +48/−0
- src/Data/Random/Source/Internal/Source.hs +142/−0
- src/Data/Random/Source/Internal/TH.hs +493/−0
- src/Data/Random/Source/Internal/Words.hs +129/−0
- src/Data/Random/Source/MWC.hs +1/−1
- src/Data/Random/Source/PureMT.hs +2/−2
- src/Data/Random/Source/Std.hs +1/−1
- src/Data/Random/Source/StdGen.hs +1/−1
random-source.cabal view
@@ -1,5 +1,5 @@ name: random-source-version: 0.3.0.4+version: 0.3.0.5 stability: provisional cabal-version: >= 1.6@@ -19,6 +19,8 @@ easy to define new entropy sources in a way that is naturally forward-compatible. .+ Changes in 0.3.0.5: Renamed some internal modules. No other changes.+ . Changes in 0.3.0.4: Fixed a typo that broke building with MTL-1 .@@ -49,10 +51,10 @@ 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+ Data.Random.Source.Internal.Words+ Data.Random.Source.Internal.Source+ other-modules: Data.Random.Source.Internal.Prim+ Data.Random.Source.Internal.TH if impl(ghc >= 6.10) -- mwc-random depends on vector, which doesn't build on GHC < 6.10.
− src/Data/Random/Internal/Prim.hs
@@ -1,48 +0,0 @@-{-# 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
@@ -1,142 +0,0 @@-{-# 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
@@ -1,493 +0,0 @@-{-# 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 Language.Haskell.TH.Extras-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--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 futzedDecsQ = do- let decQ = fmap genericalizeDecs futzedDecsQ- 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---- 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
@@ -1,129 +0,0 @@--- |A few little functions I found myself writing inline over and over again.-module Data.Random.Internal.Words where--import Data.Bits-import Data.Word-import Foreign.Marshal (allocaBytes)-import Foreign.Ptr (castPtr)-import Foreign.Storable (peek, pokeByteOff)-import System.IO.Unsafe (unsafePerformIO)---- 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
@@ -26,8 +26,8 @@ import Data.Word -import Data.Random.Internal.Source-import Data.Random.Internal.TH+import Data.Random.Source.Internal.Source+import Data.Random.Source.Internal.TH $(randomSource [d|
src/Data/Random/Source/IO.hs view
@@ -6,7 +6,7 @@ -- "Data.Random.Source.DevRandom". module Data.Random.Source.IO () where -import Data.Random.Internal.Source+import Data.Random.Source.Internal.Source #ifndef windows
+ src/Data/Random/Source/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.Source.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.Source.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/Source/Internal/Source.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE+ TemplateHaskell, GADTs, RankNTypes,+ MultiParamTypeClasses, FlexibleInstances, FlexibleContexts+ #-}++module Data.Random.Source.Internal.Source+ ( Prim(..)+ , MonadRandom(..)+ , RandomSource(..)+ , GetPrim(..)+ ) where++import Data.Random.Source.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/Source/Internal/TH.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE TemplateHaskell, GADTs #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-missing-signatures #-}+module Data.Random.Source.Internal.TH (monadRandom, randomSource) where++import Data.Bits+import Data.Generics+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Random.Source.Internal.Source (Prim(..), MonadRandom(..), RandomSource(..))+import Data.Random.Source.Internal.Words+import Language.Haskell.TH+import Language.Haskell.TH.Extras+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++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 futzedDecsQ = do+ let decQ = fmap genericalizeDecs futzedDecsQ+ 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++-- 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/Source/Internal/Words.hs view
@@ -0,0 +1,129 @@+-- |A few little functions I found myself writing inline over and over again.+module Data.Random.Source.Internal.Words where++import Data.Bits+import Data.Word+import Foreign.Marshal (allocaBytes)+import Foreign.Ptr (castPtr)+import Foreign.Storable (peek, pokeByteOff)+import System.IO.Unsafe (unsafePerformIO)++-- 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/MWC.hs view
@@ -15,7 +15,7 @@ , save, restore ) where -import Data.Random.Internal.Words+import Data.Random.Source.Internal.Words import Data.Random.Source import System.Random.MWC import Control.Monad.ST
src/Data/Random/Source/PureMT.hs view
@@ -26,8 +26,8 @@ import Control.Monad.State import qualified Control.Monad.State.Strict as S-import Data.Random.Internal.Source-import Data.Random.Internal.TH+import Data.Random.Source.Internal.Source+import Data.Random.Source.Internal.TH import Data.StateRef import System.Random.Mersenne.Pure64
src/Data/Random/Source/Std.hs view
@@ -7,7 +7,7 @@ module Data.Random.Source.Std where -import Data.Random.Internal.Source+import Data.Random.Source.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):
src/Data/Random/Source/StdGen.hs view
@@ -21,7 +21,7 @@ , getRandomPrimFromRandomGenState ) where -import Data.Random.Internal.Source+import Data.Random.Source.Internal.Source import System.Random import Control.Monad.State import qualified Control.Monad.ST.Strict as S