Skip to content

Commit

Permalink
Stop using liftM and ap in favor of <$> and <*>
Browse files Browse the repository at this point in the history
GHC versions that could not handle `<$>` and `<*>` without extra
`Functor` and `Applicative` constraints are no longer supported.
  • Loading branch information
lehins committed Dec 27, 2024
1 parent c7a34fc commit 26ba714
Show file tree
Hide file tree
Showing 3 changed files with 25 additions and 27 deletions.
36 changes: 18 additions & 18 deletions System/Random/MWC.hs
Original file line number Diff line number Diff line change
Expand Up @@ -158,7 +158,7 @@ module System.Random.MWC
#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 @@ instance Variate Word where
{-# 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 @@ -496,12 +496,12 @@ toSeed v = Seed $ I.create $ do { Gen q <- initialize v; return q }

-- | 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 @@ -591,9 +591,9 @@ aa = 1540315826
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 @@ -613,11 +613,11 @@ uniform1 f gen = do

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
11 changes: 5 additions & 6 deletions System/Random/MWC/Distributions.hs
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,6 @@ module System.Random.MWC.Distributions
) where

import Prelude hiding (mapM)
import Control.Monad (liftM)
import Control.Monad.Primitive (PrimMonad, PrimState)
import Data.Bits ((.&.))
import Data.Foldable (foldl')
Expand Down Expand Up @@ -83,7 +82,7 @@ standard :: StatefulGen g m => g -> m Double
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 +101,8 @@ standard gen = loop
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 +256,7 @@ bernoulli :: StatefulGen g m
-> 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 +273,7 @@ categorical v gen
| 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

0 comments on commit 26ba714

Please sign in to comment.