{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Control.Effect.Random
(
Random(..)
, getRandom
, getRandomR
, interleave
, runRandom
, evalRandom
, execRandom
, evalRandomIO
, RandomC(..)
, Has
, run
) where
import Control.Algebra
import Control.Applicative (Alternative(..))
import Control.Carrier.State.Strict
import Control.Monad (MonadPlus(..))
import Control.Monad.Fail
import Control.Monad.Fix
import qualified Control.Monad.Random.Class as R
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class
import qualified System.Random as R (Random(..), RandomGen(..), StdGen, newStdGen)
data Random m k
= forall a . R.Random a => Random (a -> m k)
| forall a . R.Random a => RandomR (a, a) (a -> m k)
| forall a . Interleave (m a) (a -> m k)
deriving instance Functor m => Functor (Random m)
instance HFunctor Random where
hmap f (Random k) = Random (f . k)
hmap f (RandomR r k) = RandomR r (f . k)
hmap f (Interleave m k) = Interleave (f m) (f . k)
{-# INLINE hmap #-}
instance Effect Random where
thread state handler (Random k) = Random (handler . (<$ state) . k)
thread state handler (RandomR r k) = RandomR r (handler . (<$ state) . k)
thread state handler (Interleave m k) = Interleave (handler (m <$ state)) (handler . fmap k)
{-# INLINE thread #-}
getRandom :: (Has Random sig m, R.Random a) => m a
getRandom = send (Random pure)
getRandomR :: (Has Random sig m, R.Random a) => (a, a) -> m a
getRandomR interval = send (RandomR interval pure)
interleave :: (Has Random sig m) => m a -> m a
interleave m = send (Interleave m pure)
runRandom :: g -> RandomC g m a -> m (g, a)
runRandom g = runState g . runRandomC
evalRandom :: Functor m => g -> RandomC g m a -> m a
evalRandom g = fmap snd . runRandom g
execRandom :: Functor m => g -> RandomC g m a -> m g
execRandom g = fmap fst . runRandom g
evalRandomIO :: MonadIO m => RandomC R.StdGen m a -> m a
evalRandomIO m = liftIO R.newStdGen >>= flip evalRandom m
newtype RandomC g m a = RandomC { runRandomC :: StateC g m a }
deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)
instance (Algebra sig m, Effect sig, R.RandomGen g) => R.MonadRandom (RandomC g m) where
getRandom = getRandom
{-# INLINE getRandom #-}
getRandomR = getRandomR
{-# INLINE getRandomR #-}
getRandomRs interval = (:) <$> R.getRandomR interval <*> R.getRandomRs interval
{-# INLINE getRandomRs #-}
getRandoms = (:) <$> R.getRandom <*> R.getRandoms
{-# INLINE getRandoms #-}
instance (Algebra sig m, Effect sig, R.RandomGen g) => R.MonadInterleave (RandomC g m) where
interleave = interleave
{-# INLINE interleave #-}
instance (Algebra sig m, Effect sig, R.RandomGen g) => Algebra (Random :+: sig) (RandomC g m) where
alg (L (Random k)) = RandomC $ do
(a, g') <- gets R.random
put (g' :: g)
runRandomC (k a)
alg (L (RandomR r k)) = RandomC $ do
(a, g') <- gets (R.randomR r)
put (g' :: g)
runRandomC (k a)
alg (L (Interleave m k)) = RandomC $ do
(g1, g2) <- gets R.split
put (g1 :: g)
a <- runRandomC m
put g2
runRandomC (k a)
alg (R other) = RandomC (alg (R (handleCoercible other)))
{-# INLINE alg #-}