Skip to content
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.

Commit 21b36fa

Browse files
BodigrimBodigrim
authoredJun 29, 2020
Merge 67ecbbf into 11464aa 
2 parents 11464aa + 67ecbbf commit 21b36fa

File tree

6 files changed

+379
-2
lines changed

6 files changed

+379
-2
lines changed
 

‎random.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,8 @@ library
8686
System.Random
8787
System.Random.Internal
8888
System.Random.Stateful
89+
other-modules:
90+
System.Random.GFinite
8991

9092
hs-source-dirs: src
9193
default-language: Haskell2010

‎src/System/Random.hs

+3
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,8 @@ module System.Random
2727
, Random(..)
2828
, Uniform
2929
, UniformRange
30+
, Finite
31+
3032
-- ** Standard pseudo-random number generator
3133
, StdGen
3234
, mkStdGen
@@ -64,6 +66,7 @@ import Data.Word
6466
import Foreign.C.Types
6567
import GHC.Exts
6668
import System.IO.Unsafe (unsafePerformIO)
69+
import System.Random.GFinite (Finite)
6770
import System.Random.Internal
6871
import qualified System.Random.SplitMix as SM
6972

‎src/System/Random/GFinite.hs

+272
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,272 @@
1+
-- |
2+
-- Module : System.Random.GFinite
3+
-- Copyright : (c) Andrew Lelechenko 2020
4+
-- License : BSD-style (see the file LICENSE in the 'random' repository)
5+
-- Maintainer : libraries@haskell.org
6+
--
7+
8+
{-# LANGUAGE DefaultSignatures #-}
9+
{-# LANGUAGE FlexibleContexts #-}
10+
{-# LANGUAGE LambdaCase #-}
11+
{-# LANGUAGE MagicHash #-}
12+
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TypeOperators #-}
14+
15+
module System.Random.GFinite
16+
( Cardinality(..)
17+
, Finite(..)
18+
, GFinite(..)
19+
) where
20+
21+
import Data.Bits
22+
import Data.Int
23+
import Data.Void
24+
import Data.Word
25+
import GHC.Exts (Proxy#, proxy#)
26+
import GHC.Generics
27+
28+
-- | Cardinality of a set.
29+
data Cardinality
30+
= Shift !Int -- ^ Shift n is equivalent to Card (bit n)
31+
| Card !Integer
32+
deriving (Eq, Ord, Show)
33+
34+
instance Enum Cardinality where
35+
toEnum = fromIntegral
36+
fromEnum = fromIntegral
37+
38+
instance Num Cardinality where
39+
fromInteger 1 = Shift 0 -- ()
40+
fromInteger 2 = Shift 1 -- Bool
41+
fromInteger n = Card n
42+
{-# INLINE fromInteger #-}
43+
44+
x + y = fromInteger (toInteger x + toInteger y)
45+
{-# INLINE (+) #-}
46+
47+
Shift x * Shift y = Shift (x + y)
48+
Shift x * Card y = Card (y `shiftL` x)
49+
Card x * Shift y = Card (x `shiftL` y)
50+
Card x * Card y = Card (x * y)
51+
{-# INLINE (*) #-}
52+
53+
abs = Card . abs . toInteger
54+
signum = Card . signum . toInteger
55+
negate = Card . negate . toInteger
56+
57+
instance Real Cardinality where
58+
toRational = fromIntegral
59+
60+
instance Integral Cardinality where
61+
toInteger = \case
62+
Shift n -> bit n
63+
Card n -> n
64+
{-# INLINE toInteger #-}
65+
66+
quotRem x' = \case
67+
Shift n -> (Card (x `shiftR` n), Card (x .&. (bit n - 1)))
68+
Card n -> let (q, r) = x `quotRem` n in (Card q, Card r)
69+
where
70+
x = toInteger x'
71+
{-# INLINE quotRem #-}
72+
73+
-- | A type class for data with a finite number of inhabitants.
74+
-- This type class is used
75+
-- in default implementations of 'System.Random.Stateful.Uniform'
76+
-- and 'System.Random.Stateful.UniformRange'.
77+
--
78+
-- Users are not supposed to write instances of 'Finite' manually.
79+
-- There is a default implementation in terms of 'Generic' instead.
80+
--
81+
-- >>> :set -XDeriveGeneric -XDeriveAnyClass
82+
-- >>> import GHC.Generics (Generic)
83+
-- >>> data MyBool = MyTrue | MyFalse deriving (Generic, Finite)
84+
-- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Generic, Finite)
85+
--
86+
class Finite a where
87+
cardinality :: Proxy# a -> Cardinality
88+
toFinite :: Integer -> a
89+
fromFinite :: a -> Integer
90+
91+
default cardinality :: (Generic a, GFinite (Rep a)) => Proxy# a -> Cardinality
92+
cardinality _ = gcardinality (proxy# :: Proxy# (Rep a))
93+
94+
default toFinite :: (Generic a, GFinite (Rep a)) => Integer -> a
95+
toFinite = to . toGFinite
96+
97+
default fromFinite :: (Generic a, GFinite (Rep a)) => a -> Integer
98+
fromFinite = fromGFinite . from
99+
100+
class GFinite f where
101+
gcardinality :: Proxy# f -> Cardinality
102+
toGFinite :: Integer -> f a
103+
fromGFinite :: f a -> Integer
104+
105+
instance GFinite V1 where
106+
gcardinality _ = 0
107+
{-# INLINE gcardinality #-}
108+
toGFinite = const $ error "GFinite: V1 has no inhabitants"
109+
{-# INLINE toGFinite #-}
110+
fromGFinite = const $ error "GFinite: V1 has no inhabitants"
111+
{-# INLINE fromGFinite #-}
112+
113+
instance GFinite U1 where
114+
gcardinality _ = 1
115+
{-# INLINE gcardinality #-}
116+
toGFinite = const U1
117+
{-# INLINE toGFinite #-}
118+
fromGFinite = const 0
119+
{-# INLINE fromGFinite #-}
120+
121+
instance Finite a => GFinite (K1 _x a) where
122+
gcardinality _ = cardinality (proxy# :: Proxy# a)
123+
{-# INLINE gcardinality #-}
124+
toGFinite = K1 . toFinite
125+
{-# INLINE toGFinite #-}
126+
fromGFinite = fromFinite . unK1
127+
{-# INLINE fromGFinite #-}
128+
129+
instance GFinite a => GFinite (M1 _x _y a) where
130+
gcardinality _ = gcardinality (proxy# :: Proxy# a)
131+
{-# INLINE gcardinality #-}
132+
toGFinite = M1 . toGFinite
133+
{-# INLINE toGFinite #-}
134+
fromGFinite = fromGFinite . unM1
135+
{-# INLINE fromGFinite #-}
136+
137+
instance (GFinite a, GFinite b) => GFinite (a :+: b) where
138+
gcardinality _ =
139+
gcardinality (proxy# :: Proxy# a) + gcardinality (proxy# :: Proxy# b)
140+
{-# INLINE gcardinality #-}
141+
142+
toGFinite n
143+
| n < cardA = L1 $ toGFinite n
144+
| otherwise = R1 $ toGFinite (n - cardA)
145+
where
146+
cardA = toInteger (gcardinality (proxy# :: Proxy# a))
147+
{-# INLINE toGFinite #-}
148+
149+
fromGFinite = \case
150+
L1 x -> fromGFinite x
151+
R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a))
152+
{-# INLINE fromGFinite #-}
153+
154+
instance (GFinite a, GFinite b) => GFinite (a :*: b) where
155+
gcardinality _ =
156+
gcardinality (proxy# :: Proxy# a) * gcardinality (proxy# :: Proxy# b)
157+
{-# INLINE gcardinality #-}
158+
159+
toGFinite n = toGFinite (toInteger q) :*: toGFinite (toInteger r)
160+
where
161+
cardB = gcardinality (proxy# :: Proxy# b)
162+
(q, r) = Card n `quotRem` cardB
163+
{-# INLINE toGFinite #-}
164+
165+
fromGFinite (q :*: r) =
166+
toInteger (gcardinality (proxy# :: Proxy# a) * Card (fromGFinite q)) + fromGFinite r
167+
{-# INLINE fromGFinite #-}
168+
169+
instance Finite Void
170+
instance Finite ()
171+
instance Finite Bool
172+
instance Finite Ordering
173+
174+
instance Finite Char where
175+
cardinality _ = Card $ toInteger (fromEnum (maxBound :: Char)) + 1
176+
{-# INLINE cardinality #-}
177+
toFinite = toEnum . fromInteger
178+
{-# INLINE toFinite #-}
179+
fromFinite = toInteger . fromEnum
180+
{-# INLINE fromFinite #-}
181+
182+
cardinalityDef :: forall a. (Num a, FiniteBits a) => Proxy# a -> Cardinality
183+
cardinalityDef _ = Shift (finiteBitSize (0 :: a))
184+
185+
toFiniteDef :: forall a. (Num a, FiniteBits a) => Integer -> a
186+
toFiniteDef n
187+
| isSigned (0 :: a) = fromInteger (n - bit (finiteBitSize (0 :: a) - 1))
188+
| otherwise = fromInteger n
189+
190+
fromFiniteDef :: (Integral a, FiniteBits a) => a -> Integer
191+
fromFiniteDef x
192+
| isSigned x = toInteger x + bit (finiteBitSize x - 1)
193+
| otherwise = toInteger x
194+
195+
instance Finite Word8 where
196+
cardinality = cardinalityDef
197+
{-# INLINE cardinality #-}
198+
toFinite = toFiniteDef
199+
{-# INLINE toFinite #-}
200+
fromFinite = fromFiniteDef
201+
{-# INLINE fromFinite #-}
202+
instance Finite Word16 where
203+
cardinality = cardinalityDef
204+
{-# INLINE cardinality #-}
205+
toFinite = toFiniteDef
206+
{-# INLINE toFinite #-}
207+
fromFinite = fromFiniteDef
208+
{-# INLINE fromFinite #-}
209+
instance Finite Word32 where
210+
cardinality = cardinalityDef
211+
{-# INLINE cardinality #-}
212+
toFinite = toFiniteDef
213+
{-# INLINE toFinite #-}
214+
fromFinite = fromFiniteDef
215+
{-# INLINE fromFinite #-}
216+
instance Finite Word64 where
217+
cardinality = cardinalityDef
218+
{-# INLINE cardinality #-}
219+
toFinite = toFiniteDef
220+
{-# INLINE toFinite #-}
221+
fromFinite = fromFiniteDef
222+
{-# INLINE fromFinite #-}
223+
instance Finite Word where
224+
cardinality = cardinalityDef
225+
{-# INLINE cardinality #-}
226+
toFinite = toFiniteDef
227+
{-# INLINE toFinite #-}
228+
fromFinite = fromFiniteDef
229+
{-# INLINE fromFinite #-}
230+
instance Finite Int8 where
231+
cardinality = cardinalityDef
232+
{-# INLINE cardinality #-}
233+
toFinite = toFiniteDef
234+
{-# INLINE toFinite #-}
235+
fromFinite = fromFiniteDef
236+
{-# INLINE fromFinite #-}
237+
instance Finite Int16 where
238+
cardinality = cardinalityDef
239+
{-# INLINE cardinality #-}
240+
toFinite = toFiniteDef
241+
{-# INLINE toFinite #-}
242+
fromFinite = fromFiniteDef
243+
{-# INLINE fromFinite #-}
244+
instance Finite Int32 where
245+
cardinality = cardinalityDef
246+
{-# INLINE cardinality #-}
247+
toFinite = toFiniteDef
248+
{-# INLINE toFinite #-}
249+
fromFinite = fromFiniteDef
250+
{-# INLINE fromFinite #-}
251+
instance Finite Int64 where
252+
cardinality = cardinalityDef
253+
{-# INLINE cardinality #-}
254+
toFinite = toFiniteDef
255+
{-# INLINE toFinite #-}
256+
fromFinite = fromFiniteDef
257+
{-# INLINE fromFinite #-}
258+
instance Finite Int where
259+
cardinality = cardinalityDef
260+
{-# INLINE cardinality #-}
261+
toFinite = toFiniteDef
262+
{-# INLINE toFinite #-}
263+
fromFinite = fromFiniteDef
264+
{-# INLINE fromFinite #-}
265+
266+
instance Finite a => Finite (Maybe a)
267+
instance (Finite a, Finite b) => Finite (Either a b)
268+
instance (Finite a, Finite b) => Finite (a, b)
269+
instance (Finite a, Finite b, Finite c) => Finite (a, b, c)
270+
instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d)
271+
instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e)
272+
instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f) => Finite (a, b, c, d, e, f)

‎src/System/Random/Internal.hs

+68
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@
1010
{-# LANGUAGE RankNTypes #-}
1111
{-# LANGUAGE ScopedTypeVariables #-}
1212
{-# LANGUAGE Trustworthy #-}
13+
{-# LANGUAGE TypeOperators #-}
1314
{-# LANGUAGE UnboxedTuples #-}
1415
{-# LANGUAGE UndecidableInstances #-}
1516
{-# LANGUAGE UnliftedFFITypes #-}
@@ -80,10 +81,12 @@ import Foreign.C.Types
8081
import Foreign.Ptr (plusPtr)
8182
import Foreign.Storable (Storable(pokeByteOff))
8283
import GHC.Exts
84+
import GHC.Generics
8385
import GHC.IO (IO(..))
8486
import GHC.Word
8587
import Numeric.Natural (Natural)
8688
import System.IO.Unsafe (unsafePerformIO)
89+
import System.Random.GFinite (Cardinality(..), Finite(..), GFinite(..))
8790
import qualified System.Random.SplitMix as SM
8891
import qualified System.Random.SplitMix32 as SM32
8992
#if __GLASGOW_HASKELL__ >= 800
@@ -499,9 +502,50 @@ class Uniform a where
499502
-- | Generates a value uniformly distributed over all possible values of that
500503
-- type.
501504
--
505+
-- There is also a default implementation for finitely-inhabited types.
506+
--
507+
-- >>> :set -XDeriveGeneric -XDeriveAnyClass
508+
-- >>> import GHC.Generics (Generic)
509+
-- >>> import System.Random.Stateful
510+
-- >>> data MyBool = MyTrue | MyFalse deriving (Show, Generic, Finite, Uniform)
511+
-- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Show, Generic, Finite, Uniform)
512+
-- >>> gen <- newIOGenM (mkStdGen 42)
513+
-- >>> uniformListM 10 gen :: IO [Action]
514+
-- [Code MyTrue,Code MyTrue,Eat Nothing,Code MyFalse,Eat (Just False),Eat (Just True),Eat Nothing,Eat (Just False),Sleep,Code MyFalse]
515+
--
502516
-- @since 1.2.0
503517
uniformM :: StatefulGen g m => g -> m a
504518

519+
default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a
520+
uniformM = fmap to . guniformM
521+
522+
class GUniform f where
523+
guniformM :: StatefulGen g m => g -> m (f a)
524+
525+
instance GUniform f => GUniform (M1 i c f) where
526+
guniformM = fmap M1 . guniformM
527+
528+
instance Uniform a => GUniform (K1 i a) where
529+
guniformM = fmap K1 . uniformM
530+
531+
instance GUniform U1 where
532+
guniformM _ = return U1
533+
534+
instance (GUniform f, GUniform g) => GUniform (f :*: g) where
535+
guniformM g = (:*:) <$> guniformM g <*> guniformM g
536+
537+
instance (GFinite f, GFinite g) => GUniform (f :+: g) where
538+
guniformM = finiteUniformM
539+
540+
finiteUniformM :: forall g m f a. (StatefulGen g m, GFinite f) => g -> m (f a)
541+
finiteUniformM = fmap toGFinite . case gcardinality (proxy# :: Proxy# f) of
542+
Shift n
543+
| n <= 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (bit n - 1)
544+
| otherwise -> boundedByPowerOf2ExclusiveIntegralM n
545+
Card n
546+
| n <= bit 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (fromInteger n - 1)
547+
| otherwise -> boundedExclusiveIntegralM n
548+
505549
-- | The class of types for which a uniformly distributed value can be drawn
506550
-- from a range.
507551
--
@@ -520,9 +564,23 @@ class UniformRange a where
520564
--
521565
-- > uniformRM (a, b) = uniformRM (b, a)
522566
--
567+
-- There is also a default implementation for finitely-inhabited types.
568+
--
569+
-- >>> :set -XDeriveGeneric -XDeriveAnyClass
570+
-- >>> import GHC.Generics (Generic)
571+
-- >>> import Data.Word (Word8)
572+
-- >>> import System.Random.Stateful
573+
-- >>> data Foo = Bar Word8 | Quux Word8 deriving (Show, Generic, Finite, UniformRange)
574+
-- >>> gen <- newIOGenM (mkStdGen 42)
575+
-- >>> Control.Monad.replicateM 10 (uniformRM (Bar 100, Quux 150) gen)
576+
-- [Bar 148,Bar 251,Bar 195,Quux 115,Quux 52,Bar 123,Bar 239,Bar 195,Quux 150,Quux 31]
577+
--
523578
-- @since 1.2.0
524579
uniformRM :: StatefulGen g m => (a, a) -> g -> m a
525580

581+
default uniformRM :: (StatefulGen g m, Finite a) => (a, a) -> g -> m a
582+
uniformRM (l, h) = fmap toFinite . uniformIntegralM (fromFinite l, fromFinite h)
583+
526584
instance UniformRange Integer where
527585
uniformRM = uniformIntegralM
528586

@@ -881,6 +939,8 @@ uniformIntegralM (l, h) gen = case l `compare` h of
881939
GT -> uniformIntegralM (h, l) gen
882940
EQ -> pure l
883941
{-# INLINEABLE uniformIntegralM #-}
942+
{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Integer, Integer) -> g -> m Integer #-}
943+
{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Natural, Natural) -> g -> m Natural #-}
884944

885945
-- | Generate an integral in the range @[0, s)@ using a variant of Lemire's
886946
-- multiplication method.
@@ -913,6 +973,14 @@ boundedExclusiveIntegralM s gen = go
913973
else return $ m `shiftR` k
914974
{-# INLINE boundedExclusiveIntegralM #-}
915975

976+
-- | boundedByPowerOf2ExclusiveIntegralM s ~ boundedExclusiveIntegralM (bit s)
977+
boundedByPowerOf2ExclusiveIntegralM :: (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a
978+
boundedByPowerOf2ExclusiveIntegralM s gen = do
979+
let n = (s + wordSizeInBits - 1) `quot` wordSizeInBits
980+
x <- uniformIntegralWords n gen
981+
return $ x .&. (bit s - 1)
982+
{-# INLINE boundedByPowerOf2ExclusiveIntegralM #-}
983+
916984
-- | @integralWordSize i@ returns that least @w@ such that
917985
-- @i <= WORD_SIZE_IN_BITS^w@.
918986
integralWordSize :: (Bits a, Num a) => a -> Int

‎test/Spec.hs

+33-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
22
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DeriveAnyClass #-}
35
{-# LANGUAGE FlexibleContexts #-}
46
{-# LANGUAGE FlexibleInstances #-}
57
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -9,8 +11,10 @@ module Main (main) where
911
import Data.ByteString.Short as SBS
1012
import Data.Int
1113
import Data.Typeable
14+
import Data.Void
1215
import Data.Word
1316
import Foreign.C.Types
17+
import GHC.Generics
1418
import Numeric.Natural (Natural)
1519
import System.Random
1620
import Test.SmallCheck.Series as SC
@@ -42,7 +46,7 @@ main =
4246
, integralSpec (Proxy :: Proxy Int)
4347
, integralSpec (Proxy :: Proxy Char)
4448
, integralSpec (Proxy :: Proxy Bool)
45-
#if __GLASGOW_HASKELL >= 802
49+
#if __GLASGOW_HASKELL__ >= 802
4650
, integralSpec (Proxy :: Proxy CBool)
4751
#endif
4852
, integralSpec (Proxy :: Proxy CChar)
@@ -66,6 +70,11 @@ main =
6670
, integralSpec (Proxy :: Proxy CUIntMax)
6771
, integralSpec (Proxy :: Proxy Integer)
6872
, integralSpec (Proxy :: Proxy Natural)
73+
#if __GLASGOW_HASKELL__ >= 802
74+
, integralSpec (Proxy :: Proxy MyBool)
75+
, integralSpec (Proxy :: Proxy MyAction)
76+
, integralSpec (Proxy :: Proxy Foo)
77+
#endif
6978
, runSpec
7079
, floatTests
7180
, byteStringSpec
@@ -141,3 +150,26 @@ runSpec = testGroup "runGenState_ and runPrimGenIO_"
141150
-- | Create a StdGen instance from an Int and pass it to the given function.
142151
seeded :: (StdGen -> a) -> Int -> a
143152
seeded f = f . mkStdGen
153+
154+
#if __GLASGOW_HASKELL__ >= 802
155+
156+
data MyBool = MyTrue | MyFalse
157+
deriving (Eq, Ord, Show, Generic, Finite, Uniform, UniformRange)
158+
instance Monad m => Serial m MyBool
159+
160+
data MyAction = Code (Maybe MyBool) | Never Void | Eat (Bool, Bool) | Sleep ()
161+
deriving (Eq, Ord, Show, Generic, Finite, Uniform, UniformRange)
162+
instance Monad m => Serial m MyAction
163+
164+
data Foo
165+
= Quux Char
166+
| Bar Int | Baz Word
167+
| Bar8 Int8 | Baz8 Word8
168+
| Bar16 Int16 | Baz16 Word16
169+
| Bar32 Int32 | Baz32 Word32
170+
| Bar64 Int64 | Baz64 Word64
171+
| Final ()
172+
deriving (Eq, Ord, Show, Generic, Finite, Uniform, UniformRange)
173+
instance Monad m => Serial m Foo
174+
175+
#endif

‎test/doctests.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# LANGUAGE CPP #-}
22
module Main where
33

4-
#if __GLASGOW_HASKELL__ >= 802
4+
#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ != 810
55

66
import Test.DocTest (doctest)
77

0 commit comments

Comments
 (0)
Please sign in to comment.