1{-# LANGUAGE FlexibleContexts    #-}
2{-# LANGUAGE FlexibleInstances   #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeFamilies        #-}
5module Data.PSQ.Class.Tests
6    ( tests
7    ) where
8
9import           Control.Applicative   ((<$>))
10import           Control.DeepSeq       (NFData, rnf)
11import           Data.Char             (isAlphaNum, isPrint, ord, toLower)
12import           Data.Foldable         (Foldable, foldr)
13import qualified Data.List             as List
14import           Data.Tagged           (Tagged (..), untag)
15import           Prelude               hiding (foldr, lookup, map, null)
16
17import           Test.HUnit            (Assertion, assert, (@?=))
18import           Test.QuickCheck       (Arbitrary (..), Property, forAll, (==>))
19import           Test.Tasty            (TestTree)
20import           Test.Tasty.HUnit      (testCase)
21import           Test.Tasty.QuickCheck (testProperty)
22
23import           Data.PSQ.Class
24import           Data.PSQ.Class.Gen
25import           Data.PSQ.Class.Util
26
27
28--------------------------------------------------------------------------------
29-- Index of tests
30--------------------------------------------------------------------------------
31
32tests
33    :: forall psq. (PSQ psq, TestKey (Key psq),
34                    Arbitrary (psq Int Char),
35                    Eq (psq Int Char),
36                    Foldable (psq Int),
37                    Functor (psq Int),
38                    NFData (psq Int Char),
39                    Show (psq Int Char))
40    => Tagged psq [TestTree]
41tests = Tagged
42    [ testCase "rnf"      (untag' test_rnf)
43    , testCase "equality" (untag' test_equality)
44    , testCase "size"     (untag' test_size)
45    , testCase "size2"    (untag' test_size2)
46    , testCase "empty"    (untag' test_empty)
47    , testCase "lookup"   (untag' test_lookup)
48    , testCase "findMin"  (untag' test_findMin)
49    , testCase "alter"    (untag' test_alter)
50    , testCase "alterMin" (untag' test_alterMin)
51    , testCase "fromList" (untag' test_fromList)
52    , testCase "foldr"    (untag' test_foldr)
53
54    , testProperty "show"               (untag' prop_show)
55    , testProperty "rnf"                (untag' prop_rnf)
56    , testProperty "size"               (untag' prop_size)
57    , testProperty "singleton"          (untag' prop_singleton)
58    , testProperty "memberLookup"       (untag' prop_memberLookup)
59    , testProperty "insertLookup"       (untag' prop_insertLookup)
60    , testProperty "insertDelete"       (untag' prop_insertDelete)
61    , testProperty "insertDeleteView"   (untag' prop_insertDeleteView)
62    , testProperty "deleteNonMember"    (untag' prop_deleteNonMember)
63    , testProperty "deleteMin"          (untag' prop_deleteMin)
64    , testProperty "alter"              (untag' prop_alter)
65    , testProperty "alterMin"           (untag' prop_alterMin)
66    , testProperty "toList"             (untag' prop_toList)
67    , testProperty "keys"               (untag' prop_keys)
68    , testProperty "insertView"         (untag' prop_insertView)
69    , testProperty "deleteView"         (untag' prop_deleteView)
70    , testProperty "map"                (untag' prop_map)
71    , testProperty "unsafeMapMonotonic" (untag' prop_unsafeMapMonotonic)
72    , testProperty "fmap"               (untag' prop_fmap)
73    , testProperty "fold'"              (untag' prop_fold')
74    , testProperty "foldr"              (untag' prop_foldr)
75    , testProperty "valid"              (untag' prop_valid)
76    , testProperty "atMostView"         (untag' prop_atMostView)
77    ]
78  where
79    untag' :: Tagged psq test -> test
80    untag' = untag
81
82
83--------------------------------------------------------------------------------
84-- HUnit tests
85--------------------------------------------------------------------------------
86
87test_rnf
88    :: forall psq. (PSQ psq, TestKey (Key psq),
89                    NFData (psq Int Char))
90    => Tagged psq Assertion
91test_rnf = Tagged $
92    rnf (empty :: psq Int Char) `seq` return ()
93
94test_equality
95    :: forall psq. (PSQ psq, TestKey (Key psq),
96                    Eq (psq Int Char))
97    => Tagged psq Assertion
98test_equality = Tagged $ do
99    -- Mostly to get 100% coverage
100    assert $ e /= s
101    assert $ s /= e
102  where
103    e = empty               :: psq Int Char
104    s = singleton 3 100 'a' :: psq Int Char
105
106test_size
107    :: forall psq. (PSQ psq, TestKey (Key psq))
108    => Tagged psq Assertion
109test_size = Tagged $ do
110    null (empty               :: psq Int Char) @?= True
111    null (singleton 1 100 'a' :: psq Int Char) @?= False
112
113test_size2
114    :: forall psq. (PSQ psq, TestKey (Key psq))
115    => Tagged psq Assertion
116test_size2 = Tagged $ do
117    size (empty               :: psq Int ())   @?= 0
118    size (singleton 1 100 'a' :: psq Int Char) @?= 1
119    size (fromList [(1, 100, 'a'), (2, 101, 'c'), (3, 102, 'b')]
120                              :: psq Int Char) @?= 3
121
122test_empty
123    :: forall psq. (PSQ psq, TestKey (Key psq))
124    => Tagged psq Assertion
125test_empty = Tagged $ do
126    toList (empty :: psq Int ())   @?= []
127    size   (empty :: psq Char Int) @?= 0
128
129test_lookup
130    :: forall psq. (PSQ psq, TestKey (Key psq))
131    => Tagged psq Assertion
132test_lookup = Tagged $ do
133    employeeCurrency 1 @?= Just 1
134    employeeCurrency 2 @?= Nothing
135  where
136    employeeDept    = fromList [(1, 100, 2), (3, 101, 1)] :: psq Int Int
137    deptCountry     = fromList [(1, 102, 1), (2, 103, 2)] :: psq Int Int
138    countryCurrency = fromList [(1, 104, 2), (2, 105, 1)] :: psq Int Int
139
140    employeeCurrency :: Int -> Maybe Int
141    employeeCurrency name = do
142        dept    <- snd <$> lookup (toTestKey name) employeeDept
143        country <- snd <$> lookup (toTestKey dept) deptCountry
144        snd <$> lookup (toTestKey country) countryCurrency
145
146test_findMin
147    :: forall psq. (PSQ psq, TestKey (Key psq))
148    => Tagged psq Assertion
149test_findMin = Tagged $ do
150    findMin (empty :: psq Int Char) @?= Nothing
151    findMin (fromList [(5, 101, 'a'), (3, 100, 'b')] :: psq Int Char) @?=
152        Just (3, 100, 'b')
153
154test_alter
155    :: forall psq. (PSQ psq, TestKey (Key psq),
156                    Eq (psq Int Char), Show (psq Int Char))
157    => Tagged psq Assertion
158test_alter = Tagged $ do
159    alter f 3 (empty :: psq Int Char) @?= ("Hello", singleton 3 100 'a')
160    alter f 3 (singleton 3 100 'a' :: psq Int Char) @?= ("World", empty)
161    alter f 3 (singleton 3 100 'b' :: psq Int Char) @?=
162        ("Cats", singleton 3 101 'b')
163  where
164    f Nothing           = ("Hello", Just (100, 'a'))
165    f (Just (100, 'a')) = ("World", Nothing)
166    f (Just _)          = ("Cats",  Just (101, 'b'))
167
168test_alterMin
169    :: forall psq. (PSQ psq, TestKey (Key psq),
170                    Eq (psq Int Char), Show (psq Int Char))
171    => Tagged psq Assertion
172test_alterMin = Tagged $ do
173    alterMin (\_ -> ((), Nothing)) (empty :: psq Int Char) @?= ((), empty)
174    alterMin (\_ -> ((), Nothing)) (singleton 3 100 'a'  :: psq Int Char) @?=
175        ((), empty)
176
177test_fromList
178    :: forall psq. (PSQ psq, TestKey (Key psq),
179                    Eq (psq Int Char), Show (psq Int Char))
180    => Tagged psq Assertion
181test_fromList = Tagged $
182    let ls = [(1, 0, 'A'), (2, 0, 'B'), (3, 0, 'C'), (4, 0, 'D')]
183    in (fromList ls :: psq Int Char) @?= fromList (reverse ls)
184
185test_foldr
186    :: forall psq. (PSQ psq, TestKey (Key psq),
187                    Foldable (psq Int))
188    => Tagged psq Assertion
189test_foldr = Tagged $
190    foldr (\x acc -> acc + ord x) 0 (empty :: psq Int Char) @?= 0
191
192
193--------------------------------------------------------------------------------
194-- QuickCheck properties
195--------------------------------------------------------------------------------
196
197-- | For 100% test coverage...
198prop_show
199    :: forall psq. (PSQ psq, TestKey (Key psq),
200                    Show (psq Int Char))
201    => Tagged psq Property
202prop_show = Tagged $
203    forAll arbitraryPSQ $ \t ->
204        length (coverShowInstance (t :: psq Int Char)) > 0
205
206-- | For 100% test coverage...
207prop_rnf
208    :: forall psq. (PSQ psq, TestKey (Key psq),
209                    NFData (psq Int Char), Show (psq Int Char))
210    => Tagged psq Property
211prop_rnf = Tagged $
212    forAll arbitraryPSQ $ \t ->
213        rnf (t :: psq Int Char) `seq` True
214
215prop_size
216    :: forall psq. (PSQ psq, TestKey (Key psq),
217                    Show (psq Int Char))
218    => Tagged psq (psq Int Char -> Bool)
219prop_size = Tagged $ \t ->
220    size (t :: psq Int Char) == length (toList t)
221
222prop_singleton
223    :: forall psq. (PSQ psq, TestKey (Key psq),
224                    Eq (psq Int Char))
225    => Tagged psq Property
226prop_singleton = Tagged $
227    forAll arbitraryTestKey  $ \k ->
228    forAll arbitraryPriority $ \p ->
229    forAll arbitrary         $ \x ->
230        insert k p x empty == (singleton k p x :: psq Int Char)
231
232prop_memberLookup
233    :: forall psq. (PSQ psq, TestKey (Key psq),
234                    Arbitrary (psq Int Char),
235                    Show (psq Int Char))
236    => Tagged psq (psq Int Char -> Property)
237prop_memberLookup = Tagged $ \t ->
238    forAll arbitraryTestKey $ \k ->
239        case lookup k (t :: psq Int Char) of
240            Nothing -> not (member k t)
241            Just _  -> member k t
242
243prop_insertLookup
244    :: forall psq. (PSQ psq, TestKey (Key psq),
245                    Arbitrary (psq Int Char),
246                    Show (psq Int Char))
247    => Tagged psq (psq Int Char -> Property)
248prop_insertLookup = Tagged $ \t ->
249    forAll arbitraryTestKey  $ \k ->
250    forAll arbitraryPriority $ \p ->
251    forAll arbitrary         $ \c ->
252        lookup k (insert k p c (t :: psq Int Char)) == Just (p, c)
253
254prop_insertDelete
255    :: forall psq. (PSQ psq, TestKey (Key psq),
256                    Arbitrary (psq Int Char),
257                    Eq (psq Int Char),
258                    Show (psq Int Char))
259    => Tagged psq (psq Int Char -> Property)
260prop_insertDelete = Tagged $ \t ->
261    forAll arbitraryTestKey  $ \k ->
262    forAll arbitraryPriority $ \p ->
263    forAll arbitrary         $ \c ->
264        (lookup k t == Nothing) ==>
265            (delete k (insert k p c t) == (t :: psq Int Char))
266
267prop_insertDeleteView
268    :: forall psq. (PSQ psq, TestKey (Key psq),
269                    Arbitrary (psq Int Char),
270                    Eq (psq Int Char),
271                    Show (psq Int Char))
272    => Tagged psq (psq Int Char -> Property)
273prop_insertDeleteView = Tagged $ \t ->
274    forAll arbitraryTestKey  $ \k ->
275    forAll arbitraryPriority $ \p ->
276    forAll arbitrary         $ \c ->
277        case deleteView k (insert k p c (t :: psq Int Char)) of
278            Nothing           -> False
279            Just (p', c', t')
280                | member k t -> p' == p && c' == c && size t' < size t
281                | otherwise  -> p' == p && c' == c && t' == t
282
283prop_deleteNonMember
284    :: forall psq. (PSQ psq, TestKey (Key psq),
285                    Arbitrary (psq Int Char),
286                    Eq (psq Int Char),
287                    Show (psq Int Char))
288    => Tagged psq (psq Int Char -> Property)
289prop_deleteNonMember = Tagged $ \t ->
290    forAll arbitraryTestKey $ \k ->
291        (lookup k t == Nothing) ==> (delete k t == (t :: psq Int Char))
292
293prop_deleteMin
294    :: forall psq. (PSQ psq, TestKey (Key psq),
295                    Arbitrary (psq Int Char),
296                    Eq (psq Int Char),
297                    Show (psq Int Char))
298    => Tagged psq (psq Int Char -> Bool)
299prop_deleteMin = Tagged $ \t ->
300    let t' = deleteMin t
301    in if null t
302        then t' == t
303        else case findMin t of
304                Nothing        -> False
305                Just (k, _, _) ->
306                    size t' == size t - 1 && member k t && not (member k t')
307
308prop_alter
309    :: forall psq. (PSQ psq, TestKey (Key psq),
310                    Show (psq Int Char))
311    => Tagged psq (psq Int Char -> Property)
312prop_alter = Tagged $ \t ->
313    forAll arbitraryTestKey $ \k ->
314        let ((), t') = alter f k t :: ((), psq Int Char)
315        in case lookup k t of
316            Just _  -> (size t - 1) == size t' && lookup k t' == Nothing
317            Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing
318  where
319    f Nothing  = ((), Just (100, 'a'))
320    f (Just _) = ((), Nothing)
321
322prop_alterMin
323    :: forall psq. (PSQ psq, TestKey (Key psq),
324                    Arbitrary (psq Int Char),
325                    Eq (psq Int Char),
326                    Show (psq Int Char))
327    => Tagged psq (psq Int Char -> Bool)
328prop_alterMin = Tagged $ \t ->
329    let (mbMin, t') = alterMin f (t :: psq Int Char)
330    in case mbMin of
331        Nothing        -> t' == singleton 3 100 'a'
332        Just (k, p, v) ->
333            findMin t == Just (k, p, v) &&
334            member k t &&
335            (case () of
336                _ | isAlphaNum v -> lookup k t' == Just (fromTestKey k, v)
337                  | isPrint v    -> lookup (toTestKey $ ord v) t' ==
338                                        Just (ord v, v)
339                  | otherwise    -> not (member k t'))
340  where
341    f Nothing          = (Nothing, Just (3, 100, 'a'))
342    f (Just (k, p, v))
343        | isAlphaNum v = (Just (k, p, v), Just (k, fromTestKey k, v))
344        | isPrint v    = (Just (k, p, v), Just (toTestKey (ord v), ord v, v))
345        | otherwise    = (Just (k, p, v), Nothing)
346
347prop_toList
348    :: forall psq. (PSQ psq, TestKey (Key psq),
349                    Arbitrary (psq Int Char),
350                    Eq (psq Int Char),
351                    Show (psq Int Char))
352    => Tagged psq (psq Int Char -> Bool)
353prop_toList = Tagged $ \t ->
354    (t :: psq Int Char) == fromList (toList t)
355
356prop_keys
357    :: forall psq. (PSQ psq, TestKey (Key psq),
358                    Arbitrary (psq Int Char),
359                    Show (psq Int Char))
360    => Tagged psq (psq Int Char -> Bool)
361prop_keys = Tagged $ \t ->
362    List.sort (keys (t :: psq Int Char)) ==
363        List.sort [k | (k, _, _) <- toList t]
364
365prop_insertView
366    :: forall psq. (PSQ psq, TestKey (Key psq),
367                    Arbitrary (psq Int Char),
368                    Show (psq Int Char))
369    => Tagged psq (psq Int Char -> Property)
370prop_insertView = Tagged $ \t ->
371    forAll arbitraryTestKey  $ \k ->
372    forAll arbitraryPriority $ \p ->
373    forAll arbitrary         $ \x ->
374        case insertView k p x (t :: psq Int Char) of
375            (mbPx, t') ->
376                lookup k t  == mbPx && lookup k t' == Just (p, x)
377
378prop_deleteView
379    :: forall psq. (PSQ psq, TestKey (Key psq),
380                    Arbitrary (psq Int Char),
381                    Show (psq Int Char))
382    => Tagged psq (psq Int Char -> Property)
383prop_deleteView = Tagged $ \t ->
384    forAll arbitraryTestKey $ \k ->
385        case deleteView k (t :: psq Int Char) of
386            Nothing         -> not (member k t)
387            Just (p, v, t') -> lookup k t == Just (p, v) && not (member k t')
388
389prop_map
390    :: forall psq. (PSQ psq, TestKey (Key psq),
391                    Arbitrary (psq Int Char),
392                    Eq (psq Int Char),
393                    Show (psq Int Char))
394    => Tagged psq (psq Int Char -> Bool)
395prop_map = Tagged $ \t ->
396    map f (t :: psq Int Char) ==
397        fromList (List.map (\(k, p, x) -> (k, p, f k p x)) (toList t))
398  where
399    f k p x = if fromEnum k > p then x else 'a'
400
401prop_unsafeMapMonotonic
402    :: forall psq. (PSQ psq, TestKey (Key psq),
403                    Arbitrary (psq Int Char),
404                    Eq (psq Int Char),
405                    Show (psq Int Char))
406    => Tagged psq (psq Int Char -> Bool)
407prop_unsafeMapMonotonic = Tagged $ \t ->
408    let t' = unsafeMapMonotonic f (t :: psq Int Char) :: psq Int Char in
409    valid t' &&
410    t' == fromList (List.map (\(k, p, x) -> let (p', x') = f k p x in (k, p', x'))
411                           (toList t))
412  where
413    f k p x = (p + 1, if fromEnum k > p then x else 'a')
414
415prop_fmap
416    :: forall psq. (PSQ psq, TestKey (Key psq),
417                    Arbitrary (psq Int Char),
418                    Eq (psq Int Char),
419                    Functor (psq Int),
420                    Show (psq Int Char))
421    => Tagged psq (psq Int Char -> Bool)
422prop_fmap = Tagged $ \t ->
423    fmap toLower (t :: psq Int Char) ==
424        fromList (List.map (\(p, v, x) -> (p, v, toLower x)) (toList t))
425
426prop_fold'
427    :: forall psq. (PSQ psq, TestKey (Key psq),
428                    Arbitrary (psq Int Char),
429                    Show (psq Int Char))
430    => Tagged psq (psq Int Char -> Bool)
431prop_fold' = Tagged $ \t ->
432    fold' f acc0 (t :: psq Int Char) ==
433        List.foldl' (\acc (k, p, x) -> f k p x acc) acc0 (toList t)
434  where
435    -- Needs to be commutative
436    f k p x (kpSum, xs) = (kpSum + fromEnum k + p, List.sort (x : xs))
437    acc0                = (0, [])
438
439prop_foldr
440    :: forall psq. (PSQ psq,
441                    Arbitrary (psq Int Char),
442                    Foldable (psq Int),
443                    Show (psq Int Char))
444    => Tagged psq (psq Int Char -> Bool)
445prop_foldr = Tagged $ \t ->
446    foldr f 0 (t :: psq Int Char) ==
447        List.foldr (\(_, _, x) acc -> f x acc) 0 (toList t)
448  where
449    f x acc = acc + ord x
450
451prop_valid
452    :: forall psq. (PSQ psq,
453                    Arbitrary (psq Int Char),
454                    Show (psq Int Char))
455    => Tagged psq (psq Int Char -> Bool)
456prop_valid = Tagged valid
457
458prop_atMostView
459    :: forall psq. (PSQ psq, Show (Key psq), Show (psq Int Char))
460    => Tagged psq (psq Int Char -> Property)
461prop_atMostView = Tagged $ \t ->
462    forAll arbitraryPriority $ \p ->
463        let (elems, t') = atMostView p t in
464        -- 1. Test that priorities are at most 'p'.
465        and [p' <= p | (_, p', _) <- elems] &&
466        -- 2. Test that the remaining priorities are larger than 'p'.
467        (case findMin t' of
468            Nothing         -> True
469            Just (_, p', _) -> p' > p) &&
470        -- 2. Test that the size of the removed elements and the new queue total
471        -- the original size.
472        length elems + size t' == size t
473