Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Adjust for new additions in upcoming random-1.3 #89

Merged
merged 9 commits into from
Jan 7, 2025
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension


Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
67 changes: 35 additions & 32 deletions .github/workflows/ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -18,40 +18,43 @@ jobs:
matrix:
include:
### -- Linux --
- { cabal: "3.10", os: ubuntu-latest, ghc: "8.0.2" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "8.2.2" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "8.4.4" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "8.6.5" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "8.8.4" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "8.10.7" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.0.2" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.2.8" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.4.8" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.6.5" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.6.5" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.8.2" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "8.0.2" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "8.2.2" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "8.4.4" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "8.6.5" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "8.8.4" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "8.10.7" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.0.2" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.2.8" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.4.8" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.6.6" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.8.4" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.10.1" }
- { cabal: "3.12", os: ubuntu-latest, ghc: "9.12.1" }
## -- Win --
- { cabal: "3.10", os: windows-latest, ghc: "8.4.4" }
- { cabal: "3.10", os: windows-latest, ghc: "8.6.5" }
- { cabal: "3.10", os: windows-latest, ghc: "8.8.4" }
- { cabal: "3.10", os: windows-latest, ghc: "8.10.7" }
- { cabal: "3.10", os: windows-latest, ghc: "9.0.2" }
- { cabal: "3.10", os: windows-latest, ghc: "9.2.8" }
- { cabal: "3.10", os: windows-latest, ghc: "9.4.8" }
- { cabal: "3.10", os: windows-latest, ghc: "9.6.5" }
- { cabal: "3.10", os: windows-latest, ghc: "9.6.5" }
- { cabal: "3.10", os: windows-latest, ghc: "9.8.2" }
- { cabal: "3.12", os: windows-latest, ghc: "8.4.4" }
- { cabal: "3.12", os: windows-latest, ghc: "8.6.5" }
- { cabal: "3.12", os: windows-latest, ghc: "8.8.4" }
- { cabal: "3.12", os: windows-latest, ghc: "8.10.7" }
- { cabal: "3.12", os: windows-latest, ghc: "9.0.2" }
- { cabal: "3.12", os: windows-latest, ghc: "9.2.8" }
- { cabal: "3.12", os: windows-latest, ghc: "9.4.8" }
- { cabal: "3.12", os: windows-latest, ghc: "9.6.6" }
- { cabal: "3.12", os: windows-latest, ghc: "9.8.4" }
- { cabal: "3.12", os: windows-latest, ghc: "9.10.1" }
- { cabal: "3.12", os: windows-latest, ghc: "9.12.1" }
# MacOS
- { cabal: "3.10", os: macOS-13, ghc: "8.4.4" }
- { cabal: "3.10", os: macOS-13, ghc: "8.6.5" }
- { cabal: "3.10", os: macOS-13, ghc: "8.8.4" }
- { cabal: "3.10", os: macOS-13, ghc: "8.10.7" }
- { cabal: "3.10", os: macOS-13, ghc: "9.0.2" }
- { cabal: "3.10", os: macOS-latest, ghc: "9.2.8" }
- { cabal: "3.10", os: macOS-latest, ghc: "9.4.8" }
- { cabal: "3.10", os: macOS-latest, ghc: "9.6.5" }
- { cabal: "3.10", os: macOS-latest, ghc: "9.6.5" }
- { cabal: "3.10", os: macOS-latest, ghc: "9.8.2" }
- { cabal: "3.12", os: macOS-13, ghc: "8.4.4" }
- { cabal: "3.12", os: macOS-13, ghc: "8.6.5" }
- { cabal: "3.12", os: macOS-13, ghc: "8.8.4" }
- { cabal: "3.12", os: macOS-13, ghc: "8.10.7" }
- { cabal: "3.12", os: macOS-13, ghc: "9.0.2" }
- { cabal: "3.12", os: macOS-latest, ghc: "9.2.8" }
- { cabal: "3.12", os: macOS-latest, ghc: "9.4.8" }
- { cabal: "3.12", os: macOS-latest, ghc: "9.6.6" }
- { cabal: "3.12", os: macOS-latest, ghc: "9.8.4" }
- { cabal: "3.12", os: macOS-latest, ghc: "9.10.1" }
- { cabal: "3.12", os: macOS-latest, ghc: "9.12.1" }
fail-fast: false

steps:
Expand Down
52 changes: 33 additions & 19 deletions System/Random/MWC.hs
Original file line number Diff line number Diff line change
Expand Up @@ -158,7 +158,7 @@
#include "MachDeps.h"
#endif

import Control.Monad (ap, liftM, unless)
import Control.Monad (unless)
import Control.Monad.Primitive (PrimMonad, PrimBase, PrimState, unsafePrimToIO, stToPrim)
import Control.Monad.ST (ST,runST)
import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor)
Expand Down Expand Up @@ -310,24 +310,24 @@
{-# INLINE uniformR #-}

instance (Variate a, Variate b) => Variate (a,b) where
uniform g = (,) `liftM` uniform g `ap` uniform g
uniformR ((x1,y1),(x2,y2)) g = (,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g
uniform g = (,) <$> uniform g <*> uniform g
uniformR ((x1,y1),(x2,y2)) g = (,) <$> uniformR (x1,x2) g <*> uniformR (y1,y2) g
{-# INLINE uniform #-}
{-# INLINE uniformR #-}

instance (Variate a, Variate b, Variate c) => Variate (a,b,c) where
uniform g = (,,) `liftM` uniform g `ap` uniform g `ap` uniform g
uniform g = (,,) <$> uniform g <*> uniform g <*> uniform g
uniformR ((x1,y1,z1),(x2,y2,z2)) g =
(,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap` uniformR (z1,z2) g
(,,) <$> uniformR (x1,x2) g <*> uniformR (y1,y2) g <*> uniformR (z1,z2) g
{-# INLINE uniform #-}
{-# INLINE uniformR #-}

instance (Variate a, Variate b, Variate c, Variate d) => Variate (a,b,c,d) where
uniform g = (,,,) `liftM` uniform g `ap` uniform g `ap` uniform g
`ap` uniform g
uniform g = (,,,) <$> uniform g <*> uniform g <*> uniform g
<*> uniform g
uniformR ((x1,y1,z1,t1),(x2,y2,z2,t2)) g =
(,,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap`
uniformR (z1,z2) g `ap` uniformR (t1,t2) g
(,,,) <$> uniformR (x1,x2) g <*> uniformR (y1,y2) g <*>
uniformR (z1,z2) g <*> uniformR (t1,t2) g
{-# INLINE uniform #-}
{-# INLINE uniformR #-}

Expand Down Expand Up @@ -443,7 +443,7 @@

-- | An immutable snapshot of the state of a 'Gen'.
newtype Seed = Seed (I.Vector Word32)
deriving (Eq, Show, Typeable)

Check warning on line 446 in System/Random/MWC.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.12.1

• Deriving ‘Typeable’ has no effect: all types now auto-derive Typeable

Check warning on line 446 in System/Random/MWC.hs

View workflow job for this annotation

GitHub Actions / windows-latest / ghc 9.12.1

• Deriving ‘Typeable’ has no effect: all types now auto-derive Typeable

Check warning on line 446 in System/Random/MWC.hs

View workflow job for this annotation

GitHub Actions / macOS-latest / ghc 9.12.1

• Deriving ‘Typeable’ has no effect: all types now auto-derive Typeable

-- | Convert seed into vector.
fromSeed :: Seed -> I.Vector Word32
Expand All @@ -463,14 +463,28 @@
{-# INLINE uniformWord32 #-}
uniformWord64 = uniform
{-# INLINE uniformWord64 #-}
#if MIN_VERSION_random(1,3,0)
uniformByteArrayM isPinned n g = stToPrim (Random.fillByteArrayST isPinned n (uniform g))
{-# INLINE uniformByteArrayM #-}
#else
uniformShortByteString n g = stToPrim (Random.genShortByteStringST n (uniform g))
{-# INLINE uniformShortByteString #-}
#endif

-- | @since 0.15.0.0
instance PrimMonad m => Random.FrozenGen Seed m where
type MutableGen Seed m = Gen (PrimState m)
thawGen = restore
freezeGen = save
#if MIN_VERSION_random(1,3,0)
modifyGen gen@(Gen mv) f = do
seed <- save gen
case f seed of
(a, Seed v) -> a <$ G.copy mv v
overwriteGen (Gen mv) (Seed v) = G.copy mv v

instance PrimMonad m => Random.ThawedGen Seed m where
#endif
thawGen = restore

-- | Convert vector to 'Seed'. It acts similarly to 'initialize' and
-- will accept any vector. If you want to pass seed immediately to
Expand All @@ -482,12 +496,12 @@

-- | Save the state of a 'Gen', for later use by 'restore'.
save :: PrimMonad m => Gen (PrimState m) -> m Seed
save (Gen q) = Seed `liftM` G.freeze q
save (Gen q) = Seed <$> G.freeze q
{-# INLINE save #-}

-- | Create a new 'Gen' that mirrors the state of a saved 'Seed'.
restore :: PrimMonad m => Seed -> m (Gen (PrimState m))
restore (Seed s) = Gen `liftM` G.thaw s
restore (Seed s) = Gen <$> G.thaw s
{-# INLINE restore #-}


Expand Down Expand Up @@ -577,9 +591,9 @@
uniformWord32 :: PrimMonad m => Gen (PrimState m) -> m Word32
-- NOTE [Carry value]
uniformWord32 (Gen q) = do
i <- nextIndex `liftM` M.unsafeRead q ioff
c <- fromIntegral `liftM` M.unsafeRead q coff
qi <- fromIntegral `liftM` M.unsafeRead q i
i <- nextIndex <$> M.unsafeRead q ioff
c <- fromIntegral <$> M.unsafeRead q coff
qi <- fromIntegral <$> M.unsafeRead q i
let t = aa * qi + c
c' = fromIntegral (t `shiftR` 32)
x = fromIntegral t + c'
Expand All @@ -599,11 +613,11 @@

uniform2 :: PrimMonad m => (Word32 -> Word32 -> a) -> Gen (PrimState m) -> m a
uniform2 f (Gen q) = do
i <- nextIndex `liftM` M.unsafeRead q ioff
i <- nextIndex <$> M.unsafeRead q ioff
let j = nextIndex i
c <- fromIntegral `liftM` M.unsafeRead q coff
qi <- fromIntegral `liftM` M.unsafeRead q i
qj <- fromIntegral `liftM` M.unsafeRead q j
c <- fromIntegral <$> M.unsafeRead q coff
qi <- fromIntegral <$> M.unsafeRead q i
qj <- fromIntegral <$> M.unsafeRead q j
let t = aa * qi + c
c' = fromIntegral (t `shiftR` 32)
x = fromIntegral t + c'
Expand Down
16 changes: 6 additions & 10 deletions System/Random/MWC/Distributions.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns, CPP, GADTs, FlexibleContexts, ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns, GADTs, FlexibleContexts, ScopedTypeVariables #-}
-- |
-- Module : System.Random.MWC.Distributions
-- Copyright : (c) 2012 Bryan O'Sullivan
Expand Down Expand Up @@ -40,13 +40,9 @@
) where

import Prelude hiding (mapM)
import Control.Monad (liftM)
import Control.Monad.Primitive (PrimMonad, PrimState)
import Data.Bits ((.&.))
import Data.Foldable (foldl')

Check warning on line 45 in System/Random/MWC/Distributions.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.10.1

The import of ‘Data.Foldable’ is redundant

Check warning on line 45 in System/Random/MWC/Distributions.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.12.1

The import of ‘Data.Foldable’ is redundant

Check warning on line 45 in System/Random/MWC/Distributions.hs

View workflow job for this annotation

GitHub Actions / windows-latest / ghc 9.10.1

The import of ‘Data.Foldable’ is redundant

Check warning on line 45 in System/Random/MWC/Distributions.hs

View workflow job for this annotation

GitHub Actions / windows-latest / ghc 9.12.1

The import of ‘Data.Foldable’ is redundant

Check warning on line 45 in System/Random/MWC/Distributions.hs

View workflow job for this annotation

GitHub Actions / macOS-latest / ghc 9.10.1

The import of ‘Data.Foldable’ is redundant

Check warning on line 45 in System/Random/MWC/Distributions.hs

View workflow job for this annotation

GitHub Actions / macOS-latest / ghc 9.12.1

The import of ‘Data.Foldable’ is redundant
#if !MIN_VERSION_base(4,8,0)
import Data.Traversable (Traversable)
#endif
import Data.Traversable (mapM)
import Data.Word (Word32)
import System.Random.Stateful (StatefulGen(..),Uniform(..),UniformRange(..),uniformDoublePositive01M)
Expand Down Expand Up @@ -83,7 +79,7 @@
standard gen = loop
where
loop = do
u <- (subtract 1 . (*2)) `liftM` uniformDoublePositive01M gen
u <- subtract 1 . (*2) <$> uniformDoublePositive01M gen
ri <- uniformM gen
let i = fromIntegral ((ri :: Word32) .&. 127)
bi = I.unsafeIndex blocks i
Expand All @@ -102,8 +98,8 @@
else loop
normalTail neg = tailing
where tailing = do
x <- ((/rNorm) . log) `liftM` uniformDoublePositive01M gen
y <- log `liftM` uniformDoublePositive01M gen
x <- (/ rNorm) . log <$> uniformDoublePositive01M gen
y <- log <$> uniformDoublePositive01M gen
if y * (-2) < x * x
then tailing
else return $! if neg then x - rNorm else rNorm - x
Expand Down Expand Up @@ -257,7 +253,7 @@
-> g -- ^ Generator
-> m Bool
{-# INLINE bernoulli #-}
bernoulli p gen = (<p) `liftM` uniformDoublePositive01M gen
bernoulli p gen = (< p) <$> uniformDoublePositive01M gen

-- | Random variate generator for categorical distribution.
--
Expand All @@ -274,7 +270,7 @@
| G.null v = pkgError "categorical" "empty weights!"
| otherwise = do
let cv = G.scanl1' (+) v
p <- (G.last cv *) `liftM` uniformDoublePositive01M gen
p <- (G.last cv *) <$> uniformDoublePositive01M gen
return $! case G.findIndex (>=p) cv of
Just i -> i
Nothing -> pkgError "categorical" "bad weights!"
Expand Down
5 changes: 2 additions & 3 deletions System/Random/MWC/SeedSource.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@ module System.Random.MWC.SeedSource (
, randomSourceName
) where

import Control.Monad (liftM)
import Data.Word (Word32,Word64)
import Data.Bits (shiftR)
import Data.Ratio ((%), numerator)
Expand All @@ -31,8 +30,8 @@ import System.CPUTime (cpuTimePrecision, getCPUTime)
-- Windows system.
acquireSeedTime :: IO [Word32]
acquireSeedTime = do
c <- (numerator . (% cpuTimePrecision)) `liftM` getCPUTime
t <- toRational `liftM` getPOSIXTime
c <- numerator . (% cpuTimePrecision) <$> getCPUTime
t <- toRational <$> getPOSIXTime
let n = fromIntegral (numerator t) :: Word64
return [fromIntegral c, fromIntegral n, fromIntegral (n `shiftR` 32)]

Expand Down
5 changes: 5 additions & 0 deletions changelog.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,8 @@
## Changes in 0.15.2.0

* Support for `random-1.3`.


## Changes in 0.15.1.0

* Additon of binomial sampler using the rejection sampling method in
Expand Down
15 changes: 8 additions & 7 deletions mwc-random.cabal
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
cabal-version: 3.0
build-type: Simple
name: mwc-random
version: 0.15.1.0
version: 0.15.2.0
license: BSD-2-Clause
license-file: LICENSE
copyright: 2009, 2010, 2011 Bryan O'Sullivan
Expand Down Expand Up @@ -45,9 +45,10 @@ tested-with:
|| ==9.0.2
|| ==9.2.8
|| ==9.4.8
|| ==9.6.5
|| ==9.6.5
|| ==9.8.2
|| ==9.6.6
|| ==9.8.4
|| ==9.10.1
|| ==9.12.1


source-repository head
Expand Down Expand Up @@ -120,9 +121,9 @@ test-suite mwc-prop-tests
, QuickCheck >=2.2
, vector >=0.12.1
, tasty >=1.3.1
, tasty-quickcheck
, tasty-quickcheck >=0.10.2
, tasty-hunit
, random >=1.2
, random >=1.2
, mtl
, math-functions >=0.3.4

Expand All @@ -141,7 +142,7 @@ test-suite mwc-doctests
build-depends:
base -any
, mwc-random -any
, doctest >=0.15 && <0.23
, doctest >=0.15 && <0.24
--
, bytestring
, primitive
Expand Down
7 changes: 2 additions & 5 deletions stack.yaml
Original file line number Diff line number Diff line change
@@ -1,8 +1,5 @@
resolver: lts-15.2
resolver: lts-22.43
packages:
- '.'

extra-deps:
- github: idontgetoutmuch/random
commit: 86e06b8902d4d5c32b14b6a5ef44b964280bcc32
- splitmix-0.1@sha256:d50c4d0801a35be7875a040470c09863342514930c82a7d25780a6c2efc4fda9,5249
- random-1.3.0@sha256:e5b7016e43a8f4822ebcf8cacaaa737beb62d370b988b5c69e95105d9f0fd582,6004
Loading