MapTests.hs

module MapTests where

-- Prelude

import Prelude hiding (id, (.))

-- Control

import Control.Category
import Control.Applicative

-- Data

import           Data.Foldable (toList)
import           Data.MultiChange (MultiChange)
import qualified Data.MultiChange               as MultiChange
import           Data.Map (Map)
import qualified Data.Map                       as Map
import           Data.Incremental               
import qualified Data.Incremental.Tuple         as Tuple
import qualified Data.Incremental.Map           as IncMap

import Test.QuickCheck.Function
import Distribution.TestSuite.QuickCheck
import Test.QuickCheck
import Test.QuickCheck.Poly

instance Arbitrary a => Arbitrary (PrimitiveChange a) where

    arbitrary = frequency [(1, keepGen), (5, replaceGen)] where

        keepGen = return Keep

        replaceGen = fmap ReplaceBy arbitrary

    shrink Keep            = []
    shrink (ReplaceBy val) = Keep : map ReplaceBy (shrink val)

instance Arbitrary p => Arbitrary (MultiChange p) where

    arbitrary = fmap MultiChange.fromList arbitrary

    shrink change = map MultiChange.fromList (shrink (toList change))

-- Pair changes
deriving instance (Show (DefaultChange a), Show (DefaultChange b)) =>
                  Show (Tuple.AtomicChange a b)

instance (Arbitrary (DefaultChange a), Arbitrary (DefaultChange b)) =>
         Arbitrary (Tuple.AtomicChange a b) where

    arbitrary = oneof [firstGen, secondGen] where

        firstGen = fmap Tuple.First arbitrary

        secondGen = fmap Tuple.Second arbitrary

    shrink (Tuple.First change)  = map Tuple.First (shrink change)
    shrink (Tuple.Second change) = map Tuple.Second (shrink change)

-- Map changes
instance (Arbitrary k, Arbitrary v) =>
         Arbitrary (IncMap.AtomicChange k v) where

    arbitrary = oneof [delete, insert] where

        insert = liftA2 IncMap.Insert arbitrary arbitrary

        delete = liftA IncMap.Delete arbitrary

    shrink (IncMap.Insert k v)
        = [IncMap.Insert k' v'
              | (k', v') <- shrink (k, v)]
    shrink (IncMap.Delete k)
        = [IncMap.Delete k'
              | k' <- shrink k]

newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary)

instance Change AtomicAChange where

    type Value AtomicAChange = A

    DoubleAndAdd diff $$ A integer = A (2 * integer + diff)

deriving instance Ord A

newtype AtomicBChange = TripleAndAdd Integer deriving (Show, Arbitrary)

instance Change AtomicBChange where

    type Value AtomicBChange = B

    TripleAndAdd diff $$ B integer = B (3 * integer + diff)

deriving instance Ord B

newtype AtomicCChange = QuadrupleAndAdd Integer deriving (Show, Arbitrary)

instance Change AtomicCChange where

    type Value AtomicCChange = C

    QuadrupleAndAdd diff $$ C integer = C (4 * integer + diff)

deriving instance Ord C

-- * Tests
prop_lookupTest :: A -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_lookupTest k valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.lookup k) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.lookup k) valAndChanges

prop_memberTest :: A -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_memberTest k valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.member k) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.member k) valAndChanges

prop_filterTest :: Fun B Bool -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_filterTest fun valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.filter f) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.filter f) valAndChanges
        f = apply fun

prop_mapTest :: Fun B C -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_mapTest fun valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.map f) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.map f) valAndChanges
        f = apply fun

prop_partitionTest :: Fun B Bool -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_partitionTest fun valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.partition f) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.partition f) valAndChanges
        f = apply fun

prop_unionTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool
prop_unionTest valAndChanges = prop valAndChanges where
        prop valAndChanges = map (uncurry Map.union) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.union) valAndChanges

prop_differenceTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool
prop_differenceTest valAndChanges = prop valAndChanges where
        prop valAndChanges = map (uncurry Map.difference) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.difference) valAndChanges

prop_intersectionTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool
prop_intersectionTest valAndChanges = prop valAndChanges where
        prop valAndChanges = map (uncurry Map.intersection) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.intersection) valAndChanges

prop_keysSetTest :: ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_keysSetTest valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.keysSet) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.keysSet) valAndChanges

prop_submapOfTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool
prop_submapOfTest valAndChanges = prop valAndChanges where
        prop valAndChanges = map (uncurry Map.isSubmapOf) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.isSubmapOf) valAndChanges

prop_splitTest :: A -> ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_splitTest key valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.split key) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = runTrans (IncMap.split key) valAndChanges

prop_mapKeysTest :: Fun A C -> ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool
prop_mapKeysTest fun valAndChanges = prop valAndChanges where
        prop valAndChanges = map (Map.mapKeys f) (applyChanges valAndChanges) == applyChanges valAndChanges' where
        valAndChanges' = (runTrans (IncMap.mapKeys f) valAndChanges)
        f = apply fun

applyChanges :: (Change p) => (Value p, [p]) -> [Value p]
applyChanges (val, changes) = scanl (flip ($$)) val changes


tests :: IO [Test]
tests = return
    [ 
      testProperty "lookup" prop_lookupTest
    , testProperty "member" prop_memberTest
    , testProperty "filter" prop_filterTest
    , testProperty "map" prop_mapTest
    , testProperty "partition" prop_partitionTest
    , testProperty "union" prop_unionTest
    , testProperty "difference" prop_differenceTest
    , testProperty "intersection" prop_intersectionTest
    , testProperty "keysSet" prop_keysSetTest
    , testProperty "isSubmapOf" prop_submapOfTest
    , testProperty "split" prop_splitTest
    , testProperty "mapKeys" prop_mapKeysTest
    ]