diff --git a/random-source.cabal b/random-source.cabal --- a/random-source.cabal +++ b/random-source.cabal @@ -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. diff --git a/src/Data/Random/Internal/Prim.hs b/src/Data/Random/Internal/Prim.hs deleted file mode 100644 --- a/src/Data/Random/Internal/Prim.hs +++ /dev/null @@ -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) diff --git a/src/Data/Random/Internal/Source.hs b/src/Data/Random/Internal/Source.hs deleted file mode 100644 --- a/src/Data/Random/Internal/Source.hs +++ /dev/null @@ -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 diff --git a/src/Data/Random/Internal/TH.hs b/src/Data/Random/Internal/TH.hs deleted file mode 100644 --- a/src/Data/Random/Internal/TH.hs +++ /dev/null @@ -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) diff --git a/src/Data/Random/Internal/Words.hs b/src/Data/Random/Internal/Words.hs deleted file mode 100644 --- a/src/Data/Random/Internal/Words.hs +++ /dev/null @@ -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) - diff --git a/src/Data/Random/Source.hs b/src/Data/Random/Source.hs --- a/src/Data/Random/Source.hs +++ b/src/Data/Random/Source.hs @@ -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| diff --git a/src/Data/Random/Source/IO.hs b/src/Data/Random/Source/IO.hs --- a/src/Data/Random/Source/IO.hs +++ b/src/Data/Random/Source/IO.hs @@ -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 diff --git a/src/Data/Random/Source/Internal/Prim.hs b/src/Data/Random/Source/Internal/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/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.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) diff --git a/src/Data/Random/Source/Internal/Source.hs b/src/Data/Random/Source/Internal/Source.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/Internal/Source.hs @@ -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 diff --git a/src/Data/Random/Source/Internal/TH.hs b/src/Data/Random/Source/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/Internal/TH.hs @@ -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) diff --git a/src/Data/Random/Source/Internal/Words.hs b/src/Data/Random/Source/Internal/Words.hs new file mode 100644 --- /dev/null +++ b/src/Data/Random/Source/Internal/Words.hs @@ -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) + diff --git a/src/Data/Random/Source/MWC.hs b/src/Data/Random/Source/MWC.hs --- a/src/Data/Random/Source/MWC.hs +++ b/src/Data/Random/Source/MWC.hs @@ -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 diff --git a/src/Data/Random/Source/PureMT.hs b/src/Data/Random/Source/PureMT.hs --- a/src/Data/Random/Source/PureMT.hs +++ b/src/Data/Random/Source/PureMT.hs @@ -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 diff --git a/src/Data/Random/Source/Std.hs b/src/Data/Random/Source/Std.hs --- a/src/Data/Random/Source/Std.hs +++ b/src/Data/Random/Source/Std.hs @@ -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): diff --git a/src/Data/Random/Source/StdGen.hs b/src/Data/Random/Source/StdGen.hs --- a/src/Data/Random/Source/StdGen.hs +++ b/src/Data/Random/Source/StdGen.hs @@ -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