1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TypeFamilies #-}
3
4import Control.Applicative
5import Data.Bool (bool)
6import Data.Traversable (sequenceA)
7import System.Exit (exitFailure, exitSuccess)
8
9import Data.IMap (IMap, Run(Run))
10import Data.IntMap (IntMap)
11import Test.QuickCheck
12import qualified Data.IMap as IMap
13import qualified Data.IntMap as IntMap
14
15import qualified List
16
17instance Arbitrary v => Arbitrary (Run v) where
18    arbitrary = liftA2 (\(Positive n) -> Run n) arbitrary arbitrary
19
20instance Arbitrary v => Arbitrary (IMap v) where
21    arbitrary = IMap.fromList <$> arbitrary
22
23instance (a ~ Ordering, Show b) => Show (a -> b) where
24    show f = show [f x | x <- [minBound .. maxBound]]
25
26lower :: IMap v -> IntMap v
27lower m = IntMap.fromDistinctAscList
28    [ (base+offset, v)
29    | (base, Run n v) <- IMap.unsafeToAscList m
30    , offset <- [0..n-1]
31    ]
32
33raise :: Eq v => IntMap v -> IMap v
34raise = IMap.fromList . rle . map singletonRun . IntMap.toAscList where
35    singletonRun (k, v) = (k, Run 1 v)
36
37    rle ((k, Run n v):(k', Run n' v'):kvs)
38        | k+n == k' && v == v' = rle ((k, Run (n+n') v):kvs)
39    rle (kv:kvs) = kv:rle kvs
40    rle [] = []
41
42lowerRun :: Int -> Run v -> IntMap v
43lowerRun k r = IntMap.fromAscList [(k+offset, IMap.val r) | offset <- [0..IMap.len r-1]]
44
45type O = Ordering
46type I = IMap Ordering
47
48-- These next two probably have overflow bugs that QuickCheck can't reasonably
49-- notice. Hopefully they don't come up in real use cases...
50prop_raiseLowerFaithful :: IntMap O -> Bool
51prop_raiseLowerFaithful m = m == lower (raise m)
52
53prop_equalityReflexive :: I -> Bool
54prop_equalityReflexive m = m == raise (lower m)
55
56prop_equality :: I -> I -> Bool
57prop_equality l r = (l == r) == (lower l == lower r)
58
59prop_compare :: I -> I -> Bool
60prop_compare l r = compare l r == compare (lower l) (lower r)
61
62prop_applicativeIdentity :: I -> Bool
63prop_applicativeIdentity v = (pure id <*> v) == v
64
65prop_applicativeComposition :: IMap (O -> O) -> IMap (O -> O) -> IMap O -> Bool
66prop_applicativeComposition u v w = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w))
67
68prop_applicativeHomomorphism :: (O -> O) -> O -> Bool
69prop_applicativeHomomorphism f x = (pure f <*> pure x :: I) == pure (f x)
70
71prop_applicativeInterchange :: IMap (O -> O) -> O -> Bool
72prop_applicativeInterchange u y = (u <*> pure y) == (pure ($ y) <*> u)
73
74prop_empty :: Bool
75prop_empty = lower (IMap.empty :: I) == IntMap.empty
76
77prop_singleton :: Int -> Run O -> Bool
78prop_singleton k r = lower (IMap.singleton k r) == lowerRun k r
79
80prop_insert :: Int -> Run O -> I -> Bool
81prop_insert k r m = lower (IMap.insert k r m) == IntMap.union (lowerRun k r) (lower m)
82
83prop_delete :: Int -> Run () -> I -> Bool
84prop_delete k r m = lower (IMap.delete k r m) == lower m IntMap.\\ lowerRun k r
85
86prop_splitLE :: Int -> I -> Bool
87prop_splitLE k m = (lower le, lower gt) == (le', gt') where
88    (le, gt) = IMap.splitLE k m
89    (lt, eq, gt') = IntMap.splitLookup k (lower m)
90    le' = maybe id (IntMap.insert k) eq lt
91
92prop_intersectionWith :: (O -> O -> O) -> I -> I -> Bool
93prop_intersectionWith f l r = lower (IMap.intersectionWith f l r) == IntMap.intersectionWith f (lower l) (lower r)
94
95prop_addToKeys :: Int -> I -> Bool
96prop_addToKeys n m = lower (IMap.addToKeys n m) == IntMap.mapKeysMonotonic (n+) (lower m)
97
98prop_lookup :: Int -> I -> Bool
99prop_lookup k m = IMap.lookup k m == IntMap.lookup k (lower m)
100
101prop_restrict :: Int -> Run () -> I -> Bool
102prop_restrict k r m = lower (IMap.restrict k r m) == IntMap.intersection (lower m) (lowerRun k r)
103
104prop_mapMaybe :: (O -> Maybe O) -> I -> Bool
105prop_mapMaybe f m = lower (IMap.mapMaybe f m) == IntMap.mapMaybe f (lower m)
106
107prop_null :: I -> Bool
108prop_null m = IMap.null m == IntMap.null (lower m)
109
110return []
111
112main :: IO ()
113main =
114  (all id <$> sequenceA [$quickCheckAll, List.main])
115  >>= bool exitFailure exitSuccess
116