{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif

module Test.SmallCheck.SeriesMonad where

import Control.Applicative (Applicative, Alternative, (<$>), pure, (<*>), empty, (<|>))
import Control.Arrow (second)
import Control.Monad (Monad, (>>=), return, MonadPlus, mzero, mplus)
import Control.Monad.Logic (MonadLogic, LogicT, msplit)
import Control.Monad.Reader (MonadTrans, ReaderT, runReaderT, lift)
import Data.Function ((.), ($))
import Data.Functor (Functor, fmap)
import Data.Int (Int)

-- | Maximum depth of generated test values.
--
-- For data values, it is the depth of nested constructor applications.
--
-- For functional values, it is both the depth of nested case analysis
-- and the depth of results.
--
-- @since 0.6
type Depth = Int

-- | 'Series' is a `MonadLogic` action that enumerates values of a certain
-- type, up to some depth.
--
-- The depth bound is tracked in the 'Series' monad and can be extracted using
-- 'Test.SmallCheck.Series.getDepth' and changed using 'Test.SmallCheck.Series.localDepth'.
--
-- To manipulate series at the lowest level you can use its 'Monad',
-- 'MonadPlus' and 'MonadLogic' instances. This module provides some
-- higher-level combinators which simplify creating series.
--
-- A proper 'Series' should be monotonic with respect to the depth — i.e.
-- 'Test.SmallCheck.Series.localDepth' @(+1)@ @s@ should emit all the values that @s@ emits (and
-- possibly some more).
--
-- It is also desirable that values of smaller depth come before the values
-- of greater depth.
--
-- @since 1.0
newtype Series m a = Series (ReaderT Depth (LogicT m) a)

instance Functor (Series m) where
  fmap :: forall a b. (a -> b) -> Series m a -> Series m b
fmap a -> b
f (Series ReaderT Depth (LogicT m) a
x) = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ReaderT Depth (LogicT m) a
x)

instance Monad (Series m) where
  Series ReaderT Depth (LogicT m) a
x >>= :: forall a b. Series m a -> (a -> Series m b) -> Series m b
>>= a -> Series m b
f = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series (ReaderT Depth (LogicT m) a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}. Series m a -> ReaderT Depth (LogicT m) a
unSeries forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Series m b
f)
    where
      unSeries :: Series m a -> ReaderT Depth (LogicT m) a
unSeries (Series ReaderT Depth (LogicT m) a
y) = ReaderT Depth (LogicT m) a
y
  return :: forall a. a -> Series m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Applicative (Series m) where
  pure :: forall a. a -> Series m a
pure = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Series ReaderT Depth (LogicT m) (a -> b)
x <*> :: forall a b. Series m (a -> b) -> Series m a -> Series m b
<*> Series ReaderT Depth (LogicT m) a
y = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series (ReaderT Depth (LogicT m) (a -> b)
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT Depth (LogicT m) a
y)

instance MonadPlus (Series m) where
  mzero :: forall a. Series m a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. Series m a -> Series m a -> Series m a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Alternative (Series m) where
  empty :: forall a. Series m a
empty = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series forall (f :: * -> *) a. Alternative f => f a
empty
  Series ReaderT Depth (LogicT m) a
x <|> :: forall a. Series m a -> Series m a -> Series m a
<|> Series ReaderT Depth (LogicT m) a
y = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series (ReaderT Depth (LogicT m) a
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT Depth (LogicT m) a
y)

-- This instance is written manually. Using the GND for it is not safe.
instance Monad m => MonadLogic (Series m) where
  msplit :: forall a. Series m a -> Series m (Maybe (a, Series m a))
msplit (Series ReaderT Depth (LogicT m) a
a) = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadLogic m => m a -> m (Maybe (a, m a))
msplit ReaderT Depth (LogicT m) a
a)

instance MonadTrans Series where
  lift :: forall (m :: * -> *) a. Monad m => m a -> Series m a
lift m a
a = forall (m :: * -> *) a. ReaderT Depth (LogicT m) a -> Series m a
Series forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ m a
a

runSeries :: Depth -> Series m a -> LogicT m a
runSeries :: forall (m :: * -> *) a. Depth -> Series m a -> LogicT m a
runSeries Depth
d (Series ReaderT Depth (LogicT m) a
a) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Depth (LogicT m) a
a Depth
d