{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}

{-|
Copyright   : © 2022-2023 IOHK, 2023-2025 Cardano Foundation
License     : Apache-2.0
Description : Utilities for testing 'Store' implementations.

This module provides utilities for testing 'Store' implementations.

* 'prop_StoreUpdate' is a general property test that tests
  the laws for 'updateS'.
* 'genChain' generates random sequences of deltas.
* 'StoreUnitTest' provides a monadic DSL
  for writing example test cases for 'Store'.
-}
module Test.Data.Store
    ( -- * Store laws
      GenDelta
    , prop_StoreUpdate

    -- * Generators
    , Chain (..)
    , genChain
    , shrinkChain

    -- * Unit test DSL for developing a Store
    , StoreUnitTest
    , unitTestStore
    , applyS
    , checkLaw
    , reset
    , context
    , observe
    , ignore
    ) where

import Prelude

import Control.Exception
    ( throwIO
    )
import Control.Monad
    ( forM_
    )
import Control.Monad.Trans.Class
    ( lift
    )
import Control.Monad.Trans.RWS
    ( RWST
    , ask
    , censor
    , evalRWST
    , get
    , listen
    , put
    , tell
    )
import Data.Delta
    ( Delta (..)
    )
import Data.Either
    ( isRight
    )
import Data.Store
    ( Store (loadS, updateS, writeS)
    )
import Test.QuickCheck
    ( Gen
    , Property
    , conjoin
    , counterexample
    , forAll
    , forAllShrink
    , getSize
    , (===)
    )
import Test.QuickCheck.Monadic
    ( assert
    , monadicIO
    , monitor
    , run
    )

{-----------------------------------------------------------------------------
    Store laws
------------------------------------------------------------------------------}
-- | Given a value, generate a random delta that applies to this value.
type GenDelta da = Base da -> Gen da

-- | Chain of deltas and the results of their application.
--
-- The delta that is applied *last* appears in the list *first*.
data Chain da = Chain [(Base da, da)] (Base da)

instance Show da => Show (Chain da) where
    show :: Chain da -> String
show (Chain [(Base da, da)]
adas Base da
_) = [da] -> String
forall a. Show a => a -> String
show ([da] -> String)
-> ([(Base da, da)] -> [da]) -> [(Base da, da)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Base da, da) -> da) -> [(Base da, da)] -> [da]
forall a b. (a -> b) -> [a] -> [b]
map (Base da, da) -> da
forall a b. (a, b) -> b
snd ([(Base da, da)] -> String) -> [(Base da, da)] -> String
forall a b. (a -> b) -> a -> b
$ [(Base da, da)]
adas

-- | Randomly generate a chain of deltas.
genChain :: Delta da => Gen (Base da) -> GenDelta da -> Gen (Chain da)
genChain :: forall da.
Delta da =>
Gen (Base da) -> GenDelta da -> Gen (Chain da)
genChain Gen (Base da)
gen0 GenDelta da
more = do
    Int
n <- Gen Int
getSize
    Base da
a0 <- Gen (Base da)
gen0
    Int -> Base da -> [(Base da, da)] -> Base da -> Gen (Chain da)
go Int
n Base da
a0 [] Base da
a0
  where
    go :: Int -> Base da -> [(Base da, da)] -> Base da -> Gen (Chain da)
go Int
0 Base da
_  [(Base da, da)]
das Base da
a0 = Chain da -> Gen (Chain da)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Chain da -> Gen (Chain da)) -> Chain da -> Gen (Chain da)
forall a b. (a -> b) -> a -> b
$ [(Base da, da)] -> Base da -> Chain da
forall da. [(Base da, da)] -> Base da -> Chain da
Chain [(Base da, da)]
das Base da
a0
    go Int
n Base da
alast [(Base da, da)]
das Base da
a0 = do
        da
da <- GenDelta da
more Base da
alast
        let a :: Base da
a = da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
da Base da
alast
        Int -> Base da -> [(Base da, da)] -> Base da -> Gen (Chain da)
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Base da
a ((Base da
a, da
da) (Base da, da) -> [(Base da, da)] -> [(Base da, da)]
forall a. a -> [a] -> [a]
: [(Base da, da)]
das) Base da
a0

-- | Shrink a chain of deltas.
shrinkChain :: Chain da -> [Chain da]
shrinkChain :: forall da. Chain da -> [Chain da]
shrinkChain (Chain [] Base da
_) = []
shrinkChain (Chain [(Base da, da)]
das Base da
a0) =
    [ [(Base da, da)] -> Base da -> Chain da
forall da. [(Base da, da)] -> Base da -> Chain da
Chain [] Base da
a0, [(Base da, da)] -> Base da -> Chain da
forall da. [(Base da, da)] -> Base da -> Chain da
Chain [[(Base da, da)] -> (Base da, da)
forall a. HasCallStack => [a] -> a
last [(Base da, da)]
das] Base da
a0, [(Base da, da)] -> Base da -> Chain da
forall da. [(Base da, da)] -> Base da -> Chain da
Chain ([(Base da, da)] -> [(Base da, da)]
forall a. HasCallStack => [a] -> [a]
tail [(Base da, da)]
das) Base da
a0 ]

-- | Test whether the law on 'updateS' is satisfied.
--
-- Subsumes test for the law on 'writeS' / 'loadS'.
prop_StoreUpdate
    :: (Monad m, Delta da, Eq (Base da), Show da, Show (Base da))
    => (forall b. m b -> IO b)
    -- ^ Function to embed the monad in 'IO'
    -> m (Store m qa da)
    -- ^ Creation for 'Store' that is to be tested.
    -> Gen (Base da)
    -- ^ Generator for the initial value.
    -> GenDelta da
    -- ^ Generator for deltas.
    -> Property
prop_StoreUpdate :: forall (m :: * -> *) da (qa :: * -> *).
(Monad m, Delta da, Eq (Base da), Show da, Show (Base da)) =>
(forall b. m b -> IO b)
-> m (Store m qa da) -> Gen (Base da) -> GenDelta da -> Property
prop_StoreUpdate forall b. m b -> IO b
toIO m (Store m qa da)
mkStore Gen (Base da)
gen0 GenDelta da
more =
    Gen (Base da) -> (Base da -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Base da)
gen0 ((Base da -> Property) -> Property)
-> (Base da -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Base da
a0' ->
    Gen (Chain da)
-> (Chain da -> [Chain da]) -> (Chain da -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Gen (Base da) -> GenDelta da -> Gen (Chain da)
forall da.
Delta da =>
Gen (Base da) -> GenDelta da -> Gen (Chain da)
genChain (Base da -> Gen (Base da)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Base da
a0') GenDelta da
more) Chain da -> [Chain da]
forall da. Chain da -> [Chain da]
shrinkChain ((Chain da -> Property) -> Property)
-> (Chain da -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Chain da
chain ->
        let Chain [(Base da, da)]
adas Base da
a0 = Chain da
chain
            as :: [Base da]
as = ((Base da, da) -> Base da) -> [(Base da, da)] -> [Base da]
forall a b. (a -> b) -> [a] -> [b]
map (Base da, da) -> Base da
forall a b. (a, b) -> a
fst [(Base da, da)]
adas [Base da] -> [Base da] -> [Base da]
forall a. [a] -> [a] -> [a]
++ [Base da
a0]
            das :: [da]
das = ((Base da, da) -> da) -> [(Base da, da)] -> [da]
forall a b. (a -> b) -> [a] -> [b]
map (Base da, da) -> da
forall a b. (a, b) -> b
snd [(Base da, da)]
adas
        in  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"\nUpdates applied:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((Base da -> String) -> [Base da] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Base da -> String
forall a. Show a => a -> String
show [Base da]
as))
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
                Either SomeException (Base da)
ea <- IO (Either SomeException (Base da))
-> PropertyM IO (Either SomeException (Base da))
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Either SomeException (Base da))
 -> PropertyM IO (Either SomeException (Base da)))
-> (m (Either SomeException (Base da))
    -> IO (Either SomeException (Base da)))
-> m (Either SomeException (Base da))
-> PropertyM IO (Either SomeException (Base da))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either SomeException (Base da))
-> IO (Either SomeException (Base da))
forall b. m b -> IO b
toIO (m (Either SomeException (Base da))
 -> PropertyM IO (Either SomeException (Base da)))
-> m (Either SomeException (Base da))
-> PropertyM IO (Either SomeException (Base da))
forall a b. (a -> b) -> a -> b
$ do
                    Store m qa da
store <- m (Store m qa da)
mkStore
                    Store m qa da -> Base da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS Store m qa da
store Base da
a0
                    -- first update is applied last!
                    let updates :: [(da, Base da)]
updates = [(da, Base da)] -> [(da, Base da)]
forall a. [a] -> [a]
reverse ([(da, Base da)] -> [(da, Base da)])
-> [(da, Base da)] -> [(da, Base da)]
forall a b. (a -> b) -> a -> b
$ [da] -> [Base da] -> [(da, Base da)]
forall a b. [a] -> [b] -> [(a, b)]
zip [da]
das (Int -> [Base da] -> [Base da]
forall a. Int -> [a] -> [a]
drop Int
1 [Base da]
as)
                    [(da, Base da)] -> ((da, Base da) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(da, Base da)]
updates (((da, Base da) -> m ()) -> m ())
-> ((da, Base da) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(da
da, Base da
a) -> Store m qa da -> Maybe (Base da) -> da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m qa da
store (Base da -> Maybe (Base da)
forall a. a -> Maybe a
Just Base da
a) da
da
                    Store m qa da -> m (Either SomeException (Base da))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS Store m qa da
store
                case Either SomeException (Base da)
ea of
                    Left SomeException
err -> IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
err
                    Right Base da
a -> do
                        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
                            (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"\nExpected:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Base da -> String
forall a. Show a => a -> String
show ([Base da] -> Base da
forall a. HasCallStack => [a] -> a
head [Base da]
as)
                        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
                            (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"\nGot:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Base da -> String
forall a. Show a => a -> String
show Base da
a
                        Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Base da
a Base da -> Base da -> Bool
forall a. Eq a => a -> a -> Bool
== [Base da] -> Base da
forall a. HasCallStack => [a] -> a
head [Base da]
as

{-----------------------------------------------------------------------------
    DSL for developing
------------------------------------------------------------------------------}
-- | A monadic DSL to unit test a 'Store'.
newtype StoreUnitTest m qa da r = StoreUnitTest
    { forall (m :: * -> *) (qa :: * -> *) da r.
StoreUnitTest m qa da r
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
runStoreUnitTest :: RWST
        (Store m qa da)
        [Property]
        (Base da, Base da, [da])
        m
        r
    } deriving ((forall a b.
 (a -> b) -> StoreUnitTest m qa da a -> StoreUnitTest m qa da b)
-> (forall a b.
    a -> StoreUnitTest m qa da b -> StoreUnitTest m qa da a)
-> Functor (StoreUnitTest m qa da)
forall a b. a -> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
forall a b.
(a -> b) -> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) (qa :: * -> *) da a b.
Functor m =>
a -> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
forall (m :: * -> *) (qa :: * -> *) da a b.
Functor m =>
(a -> b) -> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
$cfmap :: forall (m :: * -> *) (qa :: * -> *) da a b.
Functor m =>
(a -> b) -> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
fmap :: forall a b.
(a -> b) -> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
$c<$ :: forall (m :: * -> *) (qa :: * -> *) da a b.
Functor m =>
a -> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
<$ :: forall a b. a -> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
Functor, Functor (StoreUnitTest m qa da)
Functor (StoreUnitTest m qa da) =>
(forall a. a -> StoreUnitTest m qa da a)
-> (forall a b.
    StoreUnitTest m qa da (a -> b)
    -> StoreUnitTest m qa da a -> StoreUnitTest m qa da b)
-> (forall a b c.
    (a -> b -> c)
    -> StoreUnitTest m qa da a
    -> StoreUnitTest m qa da b
    -> StoreUnitTest m qa da c)
-> (forall a b.
    StoreUnitTest m qa da a
    -> StoreUnitTest m qa da b -> StoreUnitTest m qa da b)
-> (forall a b.
    StoreUnitTest m qa da a
    -> StoreUnitTest m qa da b -> StoreUnitTest m qa da a)
-> Applicative (StoreUnitTest m qa da)
forall a. a -> StoreUnitTest m qa da a
forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
forall a b.
StoreUnitTest m qa da (a -> b)
-> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
forall a b c.
(a -> b -> c)
-> StoreUnitTest m qa da a
-> StoreUnitTest m qa da b
-> StoreUnitTest m qa da c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *) (qa :: * -> *) da.
Monad m =>
Functor (StoreUnitTest m qa da)
forall (m :: * -> *) (qa :: * -> *) da a.
Monad m =>
a -> StoreUnitTest m qa da a
forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da (a -> b)
-> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
forall (m :: * -> *) (qa :: * -> *) da a b c.
Monad m =>
(a -> b -> c)
-> StoreUnitTest m qa da a
-> StoreUnitTest m qa da b
-> StoreUnitTest m qa da c
$cpure :: forall (m :: * -> *) (qa :: * -> *) da a.
Monad m =>
a -> StoreUnitTest m qa da a
pure :: forall a. a -> StoreUnitTest m qa da a
$c<*> :: forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da (a -> b)
-> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
<*> :: forall a b.
StoreUnitTest m qa da (a -> b)
-> StoreUnitTest m qa da a -> StoreUnitTest m qa da b
$cliftA2 :: forall (m :: * -> *) (qa :: * -> *) da a b c.
Monad m =>
(a -> b -> c)
-> StoreUnitTest m qa da a
-> StoreUnitTest m qa da b
-> StoreUnitTest m qa da c
liftA2 :: forall a b c.
(a -> b -> c)
-> StoreUnitTest m qa da a
-> StoreUnitTest m qa da b
-> StoreUnitTest m qa da c
$c*> :: forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
*> :: forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
$c<* :: forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
<* :: forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da a
Applicative, Applicative (StoreUnitTest m qa da)
Applicative (StoreUnitTest m qa da) =>
(forall a b.
 StoreUnitTest m qa da a
 -> (a -> StoreUnitTest m qa da b) -> StoreUnitTest m qa da b)
-> (forall a b.
    StoreUnitTest m qa da a
    -> StoreUnitTest m qa da b -> StoreUnitTest m qa da b)
-> (forall a. a -> StoreUnitTest m qa da a)
-> Monad (StoreUnitTest m qa da)
forall a. a -> StoreUnitTest m qa da a
forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
forall a b.
StoreUnitTest m qa da a
-> (a -> StoreUnitTest m qa da b) -> StoreUnitTest m qa da b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *) (qa :: * -> *) da.
Monad m =>
Applicative (StoreUnitTest m qa da)
forall (m :: * -> *) (qa :: * -> *) da a.
Monad m =>
a -> StoreUnitTest m qa da a
forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> (a -> StoreUnitTest m qa da b) -> StoreUnitTest m qa da b
$c>>= :: forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> (a -> StoreUnitTest m qa da b) -> StoreUnitTest m qa da b
>>= :: forall a b.
StoreUnitTest m qa da a
-> (a -> StoreUnitTest m qa da b) -> StoreUnitTest m qa da b
$c>> :: forall (m :: * -> *) (qa :: * -> *) da a b.
Monad m =>
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
>> :: forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
$creturn :: forall (m :: * -> *) (qa :: * -> *) da a.
Monad m =>
a -> StoreUnitTest m qa da a
return :: forall a. a -> StoreUnitTest m qa da a
Monad)

-- | Apply a delta to the current value.
applyS :: (Monad m, Delta da) => da -> StoreUnitTest m qa da ()
applyS :: forall (m :: * -> *) da (qa :: * -> *).
(Monad m, Delta da) =>
da -> StoreUnitTest m qa da ()
applyS da
r = RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall (m :: * -> *) (qa :: * -> *) da r.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
-> StoreUnitTest m qa da r
StoreUnitTest (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
 -> StoreUnitTest m qa da ())
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall a b. (a -> b) -> a -> b
$ do
    Store m qa da
s <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Store m qa da)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    (Base da
q, Base da
x, [da]
ds) <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Base da, Base da, [da])
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    (Base da, Base da, [da])
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put (Base da
q, da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
r Base da
x, da
r da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
ds)
    m ()
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ()
 -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ())
-> m ()
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall a b. (a -> b) -> a -> b
$ Store m qa da -> Maybe (Base da) -> da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m qa da
s (Base da -> Maybe (Base da)
forall a. a -> Maybe a
Just Base da
x) da
r

-- | Check the store laws.
checkLaw
    :: (Monad m, Eq (Base da), Show (Base da), Show da)
    => StoreUnitTest m qa da ()
checkLaw :: forall (m :: * -> *) da (qa :: * -> *).
(Monad m, Eq (Base da), Show (Base da), Show da) =>
StoreUnitTest m qa da ()
checkLaw = RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall (m :: * -> *) (qa :: * -> *) da r.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
-> StoreUnitTest m qa da r
StoreUnitTest (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
 -> StoreUnitTest m qa da ())
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall a b. (a -> b) -> a -> b
$ do
    (Base da
_, Base da
x, [da] -> [da]
forall a. [a] -> [a]
reverse -> [da]
ds) <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Base da, Base da, [da])
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    Either SomeException (Base da)
x' <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Store m qa da)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Store m qa da)
-> (Store m qa da
    -> RWST
         (Store m qa da)
         [Property]
         (Base da, Base da, [da])
         m
         (Either SomeException (Base da)))
-> RWST
     (Store m qa da)
     [Property]
     (Base da, Base da, [da])
     m
     (Either SomeException (Base da))
forall a b.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m a
-> (a
    -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m b)
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Either SomeException (Base da))
-> RWST
     (Store m qa da)
     [Property]
     (Base da, Base da, [da])
     m
     (Either SomeException (Base da))
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either SomeException (Base da))
 -> RWST
      (Store m qa da)
      [Property]
      (Base da, Base da, [da])
      m
      (Either SomeException (Base da)))
-> (Store m qa da -> m (Either SomeException (Base da)))
-> Store m qa da
-> RWST
     (Store m qa da)
     [Property]
     (Base da, Base da, [da])
     m
     (Either SomeException (Base da))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store m qa da -> m (Either SomeException (Base da))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS
    [Property]
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell
        [ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (([da], SomeException) -> String
forall a. Show a => a -> String
show ([da]
ds, Either SomeException (Base da) -> SomeException
forall {a} {b}. Either a b -> a
leftOf Either SomeException (Base da)
x')) (Either SomeException (Base da) -> Bool
forall a b. Either a b -> Bool
isRight Either SomeException (Base da)
x')
        , String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([da] -> String
forall a. Show a => a -> String
show [da]
ds) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Either SomeException (Base da) -> Base da
forall {a} {b}. Either a b -> b
rightOf Either SomeException (Base da)
x' Base da -> Base da -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Base da
x
        ]
  where
    leftOf :: Either a b -> a
leftOf (Left a
x) = a
x
    leftOf Either a b
_ = a
forall a. HasCallStack => a
undefined
    rightOf :: Either a b -> b
rightOf (Right b
x) = b
x
    rightOf Either a b
_ = b
forall a. HasCallStack => a
undefined

-- | Reset the store state to the initial value.
reset :: Monad m => StoreUnitTest m qa da ()
reset :: forall (m :: * -> *) (qa :: * -> *) da.
Monad m =>
StoreUnitTest m qa da ()
reset = RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall (m :: * -> *) (qa :: * -> *) da r.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
-> StoreUnitTest m qa da r
StoreUnitTest (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
 -> StoreUnitTest m qa da ())
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall a b. (a -> b) -> a -> b
$ do
    Store m qa da
s <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Store m qa da)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    (Base da
q, Base da
_, [da]
_) <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Base da, Base da, [da])
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    m ()
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ()
 -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ())
-> m ()
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall a b. (a -> b) -> a -> b
$ Store m qa da -> Base da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS Store m qa da
s Base da
q
    (Base da, Base da, [da])
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put (Base da
q, Base da
q, [])

-- | Run a unit test for a 'Store'.
unitTestStore
    :: (Monad m, Eq (Base da), Show (Base da), Show da)
    => Base da
    -> Store m qa da
    -> StoreUnitTest m qa da a
    -> m Property
unitTestStore :: forall (m :: * -> *) da (qa :: * -> *) a.
(Monad m, Eq (Base da), Show (Base da), Show da) =>
Base da -> Store m qa da -> StoreUnitTest m qa da a -> m Property
unitTestStore Base da
x Store m qa da
s StoreUnitTest m qa da a
f =
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property)
-> (((), [Property]) -> [Property]) -> ((), [Property]) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [Property]) -> [Property]
forall a b. (a, b) -> b
snd
        (((), [Property]) -> Property) -> m ((), [Property]) -> m Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> Store m qa da -> (Base da, Base da, [da]) -> m ((), [Property])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST (StoreUnitTest m qa da ()
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall (m :: * -> *) (qa :: * -> *) da r.
StoreUnitTest m qa da r
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
runStoreUnitTest (StoreUnitTest m qa da a
f StoreUnitTest m qa da a
-> StoreUnitTest m qa da () -> StoreUnitTest m qa da ()
forall a b.
StoreUnitTest m qa da a
-> StoreUnitTest m qa da b -> StoreUnitTest m qa da b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreUnitTest m qa da ()
forall (m :: * -> *) da (qa :: * -> *).
(Monad m, Eq (Base da), Show (Base da), Show da) =>
StoreUnitTest m qa da ()
checkLaw)) Store m qa da
s (Base da
x, Base da
x, [])

-- | Add a context to test.
context
    :: Monad m
    => (Property -> Property)
    -> StoreUnitTest m qa da x
    -> StoreUnitTest m qa da x
context :: forall (m :: * -> *) (qa :: * -> *) da x.
Monad m =>
(Property -> Property)
-> StoreUnitTest m qa da x -> StoreUnitTest m qa da x
context Property -> Property
d StoreUnitTest m qa da x
f = RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
-> StoreUnitTest m qa da x
forall (m :: * -> *) (qa :: * -> *) da r.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
-> StoreUnitTest m qa da r
StoreUnitTest (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
 -> StoreUnitTest m qa da x)
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
-> StoreUnitTest m qa da x
forall a b. (a -> b) -> a -> b
$ do
    (x
x, [Property]
w) <- RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
-> RWST
     (Store m qa da)
     [Property]
     (Base da, Base da, [da])
     m
     (x, [Property])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> RWST r w s m (a, w)
listen (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
 -> RWST
      (Store m qa da)
      [Property]
      (Base da, Base da, [da])
      m
      (x, [Property]))
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
-> RWST
     (Store m qa da)
     [Property]
     (Base da, Base da, [da])
     m
     (x, [Property])
forall a b. (a -> b) -> a -> b
$ StoreUnitTest m qa da x
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
forall (m :: * -> *) (qa :: * -> *) da r.
StoreUnitTest m qa da r
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
runStoreUnitTest StoreUnitTest m qa da x
f
    [Property]
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell ([Property]
 -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ())
-> [Property]
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall a b. (a -> b) -> a -> b
$ (Property -> Property) -> [Property] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Property -> Property
d [Property]
w
    x -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
forall a.
a -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x

-- | Observe a property on the current value of the store.
observe :: Monad m => (Base da -> Property) -> StoreUnitTest m qa da ()
observe :: forall (m :: * -> *) da (qa :: * -> *).
Monad m =>
(Base da -> Property) -> StoreUnitTest m qa da ()
observe Base da -> Property
f = RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall (m :: * -> *) (qa :: * -> *) da r.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
-> StoreUnitTest m qa da r
StoreUnitTest (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
 -> StoreUnitTest m qa da ())
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
-> StoreUnitTest m qa da ()
forall a b. (a -> b) -> a -> b
$ do
    (Base da
_, Base da
s, [da]
_) <- RWST
  (Store m qa da)
  [Property]
  (Base da, Base da, [da])
  m
  (Base da, Base da, [da])
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    [Property]
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell [Base da -> Property
f Base da
s]

-- | Ignore the properties of a sub-test.
ignore :: Monad m => StoreUnitTest m qa da x -> StoreUnitTest m qa da x
ignore :: forall (m :: * -> *) (qa :: * -> *) da x.
Monad m =>
StoreUnitTest m qa da x -> StoreUnitTest m qa da x
ignore = RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
-> StoreUnitTest m qa da x
forall (m :: * -> *) (qa :: * -> *) da r.
RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
-> StoreUnitTest m qa da r
StoreUnitTest (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
 -> StoreUnitTest m qa da x)
-> (StoreUnitTest m qa da x
    -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x)
-> StoreUnitTest m qa da x
-> StoreUnitTest m qa da x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Property] -> [Property])
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
forall (m :: * -> *) w r s a.
Monad m =>
(w -> w) -> RWST r w s m a -> RWST r w s m a
censor ([Property] -> [Property] -> [Property]
forall a b. a -> b -> a
const []) (RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
 -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x)
-> (StoreUnitTest m qa da x
    -> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x)
-> StoreUnitTest m qa da x
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreUnitTest m qa da x
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m x
forall (m :: * -> *) (qa :: * -> *) da r.
StoreUnitTest m qa da r
-> RWST (Store m qa da) [Property] (Base da, Base da, [da]) m r
runStoreUnitTest