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