MonadRandomSpec.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

{-
  This module shows how to define a component filling in
    the role of a typeclass as required by another library.

  For example you might use a library requiring `MonadRandom`.
  How can you define a `RandomGenerator` component letting you use your library?
-}
module Test.Data.Registry.MonadRandomSpec where

import Control.Monad.Random.Class as R
import Control.Monad.Trans.Random.Lazy
import Data.IORef
import qualified Data.List as L
import Data.Registry
import Protolude as P
import System.Random as R
import Test.Tasty.Extensions

-- Let's say you have this function coming from a library
-- It has a MonadRandom constraint but you would like to create a
-- component supporting the generation of random number and you
-- would like to be able to use it to call such a function
useMonadRandom :: R.MonadRandom m => m Int
useMonadRandom = R.getRandom

-- For example this Client component might require for its implementation
-- the `useMonadRandom` function
newtype Client = Client {runClient :: IO Int}

-- | What we see here is that the Client component can be implemented
--   with a RandomGenerator component which will provide a way to call
--   the library function having the MonadRandom constraint
newClient :: RandomGenerator -> Client
newClient RandomGenerator {..} = Client {..}
  where
    runClient :: IO Int
    runClient = runRandom useMonadRandom

-- This is the RandomGenerator component
-- it reuses the RandT monad which "implements" MonadRandom given a specific generator
-- it is defined for a given RandomGen type which we don't need to expose
data RandomGenerator = forall g.
  RandomGen g =>
  RandomGenerator
  { runRandom :: forall a. RandT g IO a -> IO a
  }

-- | Production Random generator component using the global StdGen
newRandomGenerator :: IO RandomGenerator
newRandomGenerator = newStdGen >>= makeRandomGenerator

-- | Random generation is "stateful" in the sense that you get a new
--   generator each time you generate a random value.
--   In this implementation we store this generator with a hidden IORef
--   (which should probably be an MVar if we use the RandomGenerator concurrently)
makeRandomGenerator :: (RandomGen g) => g -> IO RandomGenerator
makeRandomGenerator gen = do
  ref <- newIORef gen
  pure $
    RandomGenerator
      ( \a ->
          do
            g <- readIORef ref
            (r, g') <- runRandT a g
            _ <- writeIORef ref g'
            pure r
      )

-- * We can now define other ways to generate random values

-- | Configuration for generators returning pre-determined values
newtype RandomGeneratorConfig = RandomGeneratorConfig
  { seed :: Int
  }
  deriving (Eq, Show)

-- | All the values for this generator are deterministic and determined by
--   the seed in the configuration
newSeededRandomGenerator :: RandomGeneratorConfig -> IO RandomGenerator
newSeededRandomGenerator (RandomGeneratorConfig aSeed) = do
  makeRandomGenerator (mkStdGen aSeed)

-- | There is only one value for this generator determined by
--   the seed in the configuration
newFixedRandomGenerator :: RandomGeneratorConfig -> RandomGenerator
newFixedRandomGenerator (RandomGeneratorConfig aSeed) =
  RandomGenerator ((fst <$>) . flip runRandT (mkStdGen aSeed))

-- | The registry to use for production looks like this
--   It uses the global StdGen
registryProd =
  funTo @IO newClient
    <: fun newRandomGenerator

-- | And now some tests
test_client_function_with_random_values = test "a function using MonadRandom can be executed with the RandomGenerator component and return random values" $ do
  client <- liftIO $ make @(IO Client) registryProd
  results <- liftIO $ replicateM 10 $ client & runClient

  annotateShow results

  -- if we call the generator several times we should get at least 2 different values
  assert (length (L.nub results) > 2)

test_client_function_with_seeded_values = test "a function using MonadRandom can be executed with the RandomGenerator component and return predetermined values" $ do
  let registry' =
        funTo @IO (newSeededRandomGenerator (RandomGeneratorConfig 1))
          <: registryProd

  client <- liftIO $ make @(IO Client) registry'
  results <- liftIO $ replicateM 10 $ client & runClient

  annotateShow results

  -- every time we call the generator we get different values but the same list
  take 3 results === [-2241774542048937483, 8251698951335059867, 8873074891056462818]

test_client_function_with_fixed_values = test "a function using MonadRandom can be executed with the RandomGenerator component can return always the same value" $ do
  let registry' =
        funTo @IO (newFixedRandomGenerator (RandomGeneratorConfig 1))
          <: registryProd

  client <- liftIO $ make @(IO Client) registry'
  results <- liftIO $ replicateM 10 $ client & runClient

  annotateShow results

  -- every time we call the generator we get the same value
  length (L.nub results) === 1