{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Test.DBVar
    ( genUpdates
    , prop_StoreUpdates
    , GenDelta
    , Updates (..)
    ) where

import Prelude

import Control.Exception.Safe
    ( impureThrow )
import Control.Monad
    ( forM_ )
import Data.DBVar
    ( Store (loadS, updateS, writeS) )
import Data.Delta
    ( Delta (..) )
import Fmt
    ( Buildable, listF, pretty )
import Test.QuickCheck
    ( Blind (Blind), Gen, counterexample, sized )
import Test.QuickCheck.Monadic
    ( PropertyM, assert, monitor, pick )


-- | Given a value, generate a random delta starting from this value.
type GenDelta da = Base da -> Gen da

-- | A sequence of updates and values after updating.
-- The update that is applied *last* appears in the list *first*.
newtype Updates da = Updates [(Base da, da)]

instance Show da => Show (Updates da) where
    show :: Updates da -> String
show (Updates [(Base da, da)]
xs) = [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)]
xs

-- | Randomly generate a sequence of updates
genUpdates :: Delta da => Gen (Base da) -> GenDelta da -> Gen (Updates da)
genUpdates :: Gen (Base da) -> GenDelta da -> Gen (Updates da)
genUpdates Gen (Base da)
gen0 GenDelta da
more = (Int -> Gen (Updates da)) -> Gen (Updates da)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (Updates da)) -> Gen (Updates da))
-> (Int -> Gen (Updates da)) -> Gen (Updates da)
forall a b. (a -> b) -> a -> b
$ \Int
n -> Int -> [(Base da, da)] -> Base da -> Gen (Updates da)
forall t.
(Eq t, Num t) =>
t -> [(Base da, da)] -> Base da -> Gen (Updates da)
go Int
n [] (Base da -> Gen (Updates da)) -> Gen (Base da) -> Gen (Updates da)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (Base da)
gen0
  where
    go :: t -> [(Base da, da)] -> Base da -> Gen (Updates da)
go t
0 [(Base da, da)]
das Base da
_  = Updates da -> Gen (Updates da)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updates da -> Gen (Updates da)) -> Updates da -> Gen (Updates da)
forall a b. (a -> b) -> a -> b
$ [(Base da, da)] -> Updates da
forall da. [(Base da, da)] -> Updates da
Updates [(Base da, da)]
das
    go t
n [(Base da, da)]
das Base da
a0 = do
        da
da <- GenDelta da
more Base da
a0
        let a1 :: Base da
a1 = da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
da Base da
a0
        t -> [(Base da, da)] -> Base da -> Gen (Updates da)
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) ((Base da
a1,da
da)(Base da, da) -> [(Base da, da)] -> [(Base da, da)]
forall a. a -> [a] -> [a]
:[(Base da, da)]
das) Base da
a1

-- | Test whether 'updateS' and 'loadS' behave as expected.
--
-- TODO: Shrinking of the update sequence.
prop_StoreUpdates
    :: ( Monad m, Delta da, Eq (Base da), Buildable da, Show (Base da))
    => (forall b. m b -> PropertyM IO b)
    -- ^ Function to embed the monad in 'IO'
    -> Store m da
    -- ^ Store that is to be tested.
    -> Gen (Base da)
    -- ^ Generator for the initial value.
    -> GenDelta da
    -- ^ Generator for deltas.
    -> PropertyM IO ()
prop_StoreUpdates :: (forall b. m b -> PropertyM IO b)
-> Store m da -> Gen (Base da) -> GenDelta da -> PropertyM IO ()
prop_StoreUpdates forall b. m b -> PropertyM IO b
toPropertyM Store m da
store Gen (Base da)
gen0 GenDelta da
more = do

    -- randomly generate a sequence of updates
    Blind Base da
a0 <- Gen (Blind (Base da)) -> PropertyM IO (Blind (Base da))
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen (Blind (Base da)) -> PropertyM IO (Blind (Base da)))
-> Gen (Blind (Base da)) -> PropertyM IO (Blind (Base da))
forall a b. (a -> b) -> a -> b
$ Base da -> Blind (Base da)
forall a. a -> Blind a
Blind (Base da -> Blind (Base da))
-> Gen (Base da) -> Gen (Blind (Base da))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Base da)
gen0
    Blind (Updates [(Base da, da)]
adas) <- Gen (Blind (Updates da)) -> PropertyM IO (Blind (Updates da))
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen (Blind (Updates da)) -> PropertyM IO (Blind (Updates da)))
-> Gen (Blind (Updates da)) -> PropertyM IO (Blind (Updates da))
forall a b. (a -> b) -> a -> b
$ Updates da -> Blind (Updates da)
forall a. a -> Blind a
Blind (Updates da -> Blind (Updates da))
-> Gen (Updates da) -> Gen (Blind (Updates da))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Base da) -> GenDelta da -> Gen (Updates da)
forall da.
Delta da =>
Gen (Base da) -> GenDelta da -> Gen (Updates da)
genUpdates (Base da -> Gen (Base da)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Base da
a0) GenDelta da
more
    let 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

    (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
"\nUpdates applied:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ([da] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF [da]
das)

    -- apply those updates
    Either SomeException (Base da)
ea <- m (Either SomeException (Base da))
-> PropertyM IO (Either SomeException (Base da))
forall b. m b -> PropertyM IO b
toPropertyM (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 da -> Base da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store m 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 da -> Base da -> da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store m da
store Base da
a da
da
        Store m da -> m (Either SomeException (Base da))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store m da
store

    -- check whether the last value is correct
    case Either SomeException (Base da)
ea of
        Left SomeException
err -> SomeException -> PropertyM IO ()
forall e a. Exception e => e -> a
impureThrow 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. [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. [a] -> a
head [Base da]
as