Convert to cabal.project
[packages/containers.git] / containers-tests / tests / seq-properties.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE PatternGuards #-}
3
4 #include "containers.h"
5
6 import Data.Sequence.Internal
7 ( Sized (..)
8 , Seq (Seq)
9 , FingerTree(..)
10 , Node(..)
11 , Elem(..)
12 , Digit (..)
13 , node2
14 , node3
15 , deep )
16
17 import Data.Sequence
18
19 import Control.Applicative (Applicative(..), liftA2)
20 import Control.Arrow ((***))
21 import Control.Monad.Trans.State.Strict
22 import Data.Array (listArray)
23 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, fold), toList, all, sum, foldl', foldr')
24 import Data.Functor ((<$>), (<$))
25 import Data.Maybe
26 import Data.Function (on)
27 import Data.Monoid (Monoid(..), All(..), Endo(..), Dual(..))
28 #if MIN_VERSION_base(4,9,0)
29 import Data.Semigroup (stimes, stimesMonoid)
30 #endif
31 import Data.Traversable (Traversable(traverse), sequenceA)
32 import Prelude hiding (
33 lookup, null, length, take, drop, splitAt,
34 foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1,
35 filter, reverse, replicate, zip, zipWith, zip3, zipWith3,
36 all, sum)
37 import qualified Prelude
38 import qualified Data.List
39 import Test.QuickCheck hiding ((><))
40 import Test.QuickCheck.Poly
41 #if __GLASGOW_HASKELL__ >= 800
42 import Test.QuickCheck.Property
43 #endif
44 import Test.QuickCheck.Function
45 import Test.Framework
46 import Test.Framework.Providers.QuickCheck2
47 import Control.Monad.Zip (MonadZip (..))
48 import Control.DeepSeq (deepseq)
49 import Control.Monad.Fix (MonadFix (..))
50
51
52 main :: IO ()
53 main = defaultMain
54 [ testProperty "fmap" prop_fmap
55 , testProperty "(<$)" prop_constmap
56 , testProperty "foldr" prop_foldr
57 , testProperty "foldr'" prop_foldr'
58 , testProperty "lazy foldr'" prop_lazyfoldr'
59 , testProperty "foldr1" prop_foldr1
60 , testProperty "foldl" prop_foldl
61 , testProperty "foldl'" prop_foldl'
62 , testProperty "lazy foldl'" prop_lazyfoldl'
63 , testProperty "foldl1" prop_foldl1
64 , testProperty "(==)" prop_equals
65 , testProperty "compare" prop_compare
66 , testProperty "mappend" prop_mappend
67 , testProperty "singleton" prop_singleton
68 , testProperty "(<|)" prop_cons
69 , testProperty "(|>)" prop_snoc
70 , testProperty "(><)" prop_append
71 , testProperty "fromList" prop_fromList
72 , testProperty "fromFunction" prop_fromFunction
73 , testProperty "fromArray" prop_fromArray
74 , testProperty "replicate" prop_replicate
75 , testProperty "replicateA" prop_replicateA
76 , testProperty "replicateM" prop_replicateM
77 , testProperty "iterateN" prop_iterateN
78 , testProperty "unfoldr" prop_unfoldr
79 , testProperty "unfoldl" prop_unfoldl
80 , testProperty "null" prop_null
81 , testProperty "length" prop_length
82 , testProperty "viewl" prop_viewl
83 , testProperty "viewr" prop_viewr
84 , testProperty "scanl" prop_scanl
85 , testProperty "scanl1" prop_scanl1
86 , testProperty "scanr" prop_scanr
87 , testProperty "scanr1" prop_scanr1
88 , testProperty "tails" prop_tails
89 , testProperty "inits" prop_inits
90 , testProperty "takeWhileL" prop_takeWhileL
91 , testProperty "takeWhileR" prop_takeWhileR
92 , testProperty "dropWhileL" prop_dropWhileL
93 , testProperty "dropWhileR" prop_dropWhileR
94 , testProperty "spanl" prop_spanl
95 , testProperty "spanr" prop_spanr
96 , testProperty "breakl" prop_breakl
97 , testProperty "breakr" prop_breakr
98 , testProperty "partition" prop_partition
99 , testProperty "filter" prop_filter
100 , testProperty "sort" prop_sort
101 , testProperty "sortStable" prop_sortStable
102 , testProperty "sortBy" prop_sortBy
103 , testProperty "sortOn" prop_sortOn
104 , testProperty "sortOnStable" prop_sortOnStable
105 , testProperty "unstableSort" prop_unstableSort
106 , testProperty "unstableSortBy" prop_unstableSortBy
107 , testProperty "unstableSortOn" prop_unstableSortOn
108 , testProperty "index" prop_index
109 , testProperty "(!?)" prop_safeIndex
110 , testProperty "adjust" prop_adjust
111 , testProperty "insertAt" prop_insertAt
112 , testProperty "deleteAt" prop_deleteAt
113 , testProperty "update" prop_update
114 , testProperty "take" prop_take
115 , testProperty "drop" prop_drop
116 , testProperty "splitAt" prop_splitAt
117 , testProperty "chunksOf" prop_chunksOf
118 , testProperty "elemIndexL" prop_elemIndexL
119 , testProperty "elemIndicesL" prop_elemIndicesL
120 , testProperty "elemIndexR" prop_elemIndexR
121 , testProperty "elemIndicesR" prop_elemIndicesR
122 , testProperty "findIndexL" prop_findIndexL
123 , testProperty "findIndicesL" prop_findIndicesL
124 , testProperty "findIndexR" prop_findIndexR
125 , testProperty "findIndicesR" prop_findIndicesR
126 , testProperty "foldlWithIndex" prop_foldlWithIndex
127 , testProperty "foldrWithIndex" prop_foldrWithIndex
128 , testProperty "mapWithIndex" prop_mapWithIndex
129 , testProperty "foldMapWithIndex/foldlWithIndex" prop_foldMapWithIndexL
130 , testProperty "foldMapWithIndex/foldrWithIndex" prop_foldMapWithIndexR
131 , testProperty "traverseWithIndex" prop_traverseWithIndex
132 , testProperty "reverse" prop_reverse
133 , testProperty "zip" prop_zip
134 , testProperty "zipWith" prop_zipWith
135 , testProperty "zip3" prop_zip3
136 , testProperty "zipWith3" prop_zipWith3
137 , testProperty "zip4" prop_zip4
138 , testProperty "zipWith4" prop_zipWith4
139 , testProperty "mzip-naturality" prop_mzipNaturality
140 , testProperty "mzip-preservation" prop_mzipPreservation
141 , testProperty "munzip-lazy" prop_munzipLazy
142 , testProperty "<*>" prop_ap
143 , testProperty "<*> NOINLINE" prop_ap_NOINLINE
144 , testProperty "liftA2" prop_liftA2
145 , testProperty "*>" prop_then
146 , testProperty "cycleTaking" prop_cycleTaking
147 , testProperty "intersperse" prop_intersperse
148 , testProperty ">>=" prop_bind
149 , testProperty "mfix" test_mfix
150 #if __GLASGOW_HASKELL__ >= 800
151 , testProperty "Empty pattern" prop_empty_pat
152 , testProperty "Empty constructor" prop_empty_con
153 , testProperty "Left view pattern" prop_viewl_pat
154 , testProperty "Left view constructor" prop_viewl_con
155 , testProperty "Right view pattern" prop_viewr_pat
156 , testProperty "Right view constructor" prop_viewr_con
157 #endif
158 #if MIN_VERSION_base(4,9,0)
159 , testProperty "stimes" prop_stimes
160 #endif
161 ]
162
163 ------------------------------------------------------------------------
164 -- Arbitrary
165 ------------------------------------------------------------------------
166
167 instance Arbitrary a => Arbitrary (Seq a) where
168 arbitrary = Seq <$> arbitrary
169 shrink (Seq x) = map Seq (shrink x)
170
171 instance Arbitrary a => Arbitrary (Elem a) where
172 arbitrary = Elem <$> arbitrary
173
174 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
175 arbitrary = sized arb
176 where
177 arb :: (Arbitrary b, Sized b) => Int -> Gen (FingerTree b)
178 arb 0 = return EmptyT
179 arb 1 = Single <$> arbitrary
180 arb n = do
181 pr <- arbitrary
182 sf <- arbitrary
183 let n_pr = Prelude.length (toList pr)
184 let n_sf = Prelude.length (toList sf)
185 -- adding n `div` 7 ensures that n_m >= 0, and makes more Singles
186 let n_m = max (n `div` 7) ((n - n_pr - n_sf) `div` 3)
187 m <- arb n_m
188 return $ deep pr m sf
189
190 shrink (Deep _ (One a) EmptyT (One b)) = [Single a, Single b]
191 shrink (Deep _ pr m sf) =
192 [deep pr' m sf | pr' <- shrink pr] ++
193 [deep pr m' sf | m' <- shrink m] ++
194 [deep pr m sf' | sf' <- shrink sf]
195 shrink (Single x) = map Single (shrink x)
196 shrink EmptyT = []
197
198 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
199 arbitrary = oneof [
200 node2 <$> arbitrary <*> arbitrary,
201 node3 <$> arbitrary <*> arbitrary <*> arbitrary]
202
203 shrink (Node2 _ a b) =
204 [node2 a' b | a' <- shrink a] ++
205 [node2 a b' | b' <- shrink b]
206 shrink (Node3 _ a b c) =
207 [node2 a b, node2 a c, node2 b c] ++
208 [node3 a' b c | a' <- shrink a] ++
209 [node3 a b' c | b' <- shrink b] ++
210 [node3 a b c' | c' <- shrink c]
211
212 instance Arbitrary a => Arbitrary (Digit a) where
213 arbitrary = oneof [
214 One <$> arbitrary,
215 Two <$> arbitrary <*> arbitrary,
216 Three <$> arbitrary <*> arbitrary <*> arbitrary,
217 Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]
218
219 shrink (One a) = map One (shrink a)
220 shrink (Two a b) = [One a, One b]
221 shrink (Three a b c) = [Two a b, Two a c, Two b c]
222 shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
223
224 ------------------------------------------------------------------------
225 -- Valid trees
226 ------------------------------------------------------------------------
227
228 class Valid a where
229 valid :: a -> Bool
230
231 instance Valid (Elem a) where
232 valid _ = True
233
234 instance Valid (Seq a) where
235 valid (Seq xs) = valid xs
236
237 instance (Sized a, Valid a) => Valid (FingerTree a) where
238 valid EmptyT = True
239 valid (Single x) = valid x
240 valid (Deep s pr m sf) =
241 s == size pr + size m + size sf && valid pr && valid m && valid sf
242
243 instance (Sized a, Valid a) => Valid (Node a) where
244 valid node = size node == sum (fmap size node) && all valid node
245
246 instance Valid a => Valid (Digit a) where
247 valid = all valid
248
249 {--------------------------------------------------------------------
250 The general plan is to compare each function with a list equivalent.
251 Each operation should produce a valid tree representing the same
252 sequence as produced by its list counterpart on corresponding inputs.
253 (The list versions are often lazier, but these properties ignore
254 strictness.)
255 --------------------------------------------------------------------}
256
257 -- utilities for partial conversions
258
259 infix 4 ~=
260
261 (~=) :: Eq a => Maybe a -> a -> Bool
262 (~=) = maybe (const False) (==)
263
264 -- Partial conversion of an output sequence to a list.
265 toList' :: Seq a -> Maybe [a]
266 toList' xs
267 | valid xs = Just (toList xs)
268 | otherwise = Nothing
269
270 toListList' :: Seq (Seq a) -> Maybe [[a]]
271 toListList' xss = toList' xss >>= mapM toList'
272
273 toListPair' :: (Seq a, Seq b) -> Maybe ([a], [b])
274 toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys
275
276 -- Extra "polymorphic" test type
277 newtype D = D{ unD :: Integer }
278 deriving ( Eq )
279
280 instance Show D where
281 showsPrec n (D x) = showsPrec n x
282
283 instance Arbitrary D where
284 arbitrary = (D . (+1) . abs) `fmap` arbitrary
285 shrink (D x) = [ D x' | x' <- shrink x, x' > 0 ]
286
287 instance CoArbitrary D where
288 coarbitrary = coarbitrary . unD
289
290 -- instances
291
292 prop_fmap :: Seq Int -> Bool
293 prop_fmap xs =
294 toList' (fmap f xs) ~= map f (toList xs)
295 where f = (+100)
296
297 prop_constmap :: A -> Seq A -> Bool
298 prop_constmap x xs =
299 toList' (x <$ xs) ~= map (const x) (toList xs)
300
301 prop_foldr :: Seq A -> Property
302 prop_foldr xs =
303 foldr f z xs === Prelude.foldr f z (toList xs)
304 where
305 f = (:)
306 z = []
307
308 prop_foldr' :: Seq A -> Property
309 prop_foldr' xs =
310 foldr' f z xs === foldr' f z (toList xs)
311 where
312 f = (:)
313 z = []
314
315 prop_lazyfoldr' :: Seq () -> Property
316 prop_lazyfoldr' xs =
317 not (null xs) ==>
318 foldr'
319 (\e _ ->
320 e)
321 (error "Data.Sequence.foldr': should be lazy in initial accumulator")
322 xs ===
323 ()
324
325 prop_foldr1 :: Seq Int -> Property
326 prop_foldr1 xs =
327 not (null xs) ==> foldr1 f xs == Data.List.foldr1 f (toList xs)
328 where f = (-)
329
330 prop_foldl :: Seq A -> Property
331 prop_foldl xs =
332 foldl f z xs === Prelude.foldl f z (toList xs)
333 where
334 f = flip (:)
335 z = []
336
337 prop_foldl' :: Seq A -> Property
338 prop_foldl' xs =
339 foldl' f z xs === foldl' f z (toList xs)
340 where
341 f = flip (:)
342 z = []
343
344 prop_lazyfoldl' :: Seq () -> Property
345 prop_lazyfoldl' xs =
346 not (null xs) ==>
347 foldl'
348 (\_ e ->
349 e)
350 (error "Data.Sequence.foldl': should be lazy in initial accumulator")
351 xs ===
352 ()
353
354 prop_foldl1 :: Seq Int -> Property
355 prop_foldl1 xs =
356 not (null xs) ==> foldl1 f xs == Data.List.foldl1 f (toList xs)
357 where f = (-)
358
359 prop_equals :: Seq OrdA -> Seq OrdA -> Bool
360 prop_equals xs ys =
361 (xs == ys) == (toList xs == toList ys)
362
363 prop_compare :: Seq OrdA -> Seq OrdA -> Bool
364 prop_compare xs ys =
365 compare xs ys == compare (toList xs) (toList ys)
366
367 prop_mappend :: Seq A -> Seq A -> Bool
368 prop_mappend xs ys =
369 toList' (mappend xs ys) ~= toList xs ++ toList ys
370
371 -- * Construction
372
373 {-
374 toList' empty ~= []
375 -}
376
377 prop_singleton :: A -> Bool
378 prop_singleton x =
379 toList' (singleton x) ~= [x]
380
381 prop_cons :: A -> Seq A -> Bool
382 prop_cons x xs =
383 toList' (x <| xs) ~= x : toList xs
384
385 prop_snoc :: Seq A -> A -> Bool
386 prop_snoc xs x =
387 toList' (xs |> x) ~= toList xs ++ [x]
388
389 prop_append :: Seq A -> Seq A -> Bool
390 prop_append xs ys =
391 toList' (xs >< ys) ~= toList xs ++ toList ys
392
393 prop_fromList :: [A] -> Bool
394 prop_fromList xs =
395 toList' (fromList xs) ~= xs
396
397 prop_fromFunction :: [A] -> Bool
398 prop_fromFunction xs =
399 toList' (fromFunction (Prelude.length xs) (xs!!)) ~= xs
400
401 prop_fromArray :: [A] -> Bool
402 prop_fromArray xs =
403 toList' (fromArray (listArray (42, 42+Prelude.length xs-1) xs)) ~= xs
404
405 -- ** Repetition
406
407 prop_replicate :: NonNegative Int -> A -> Bool
408 prop_replicate (NonNegative m) x =
409 toList' (replicate n x) ~= Prelude.replicate n x
410 where n = m `mod` 10000
411
412 prop_replicateA :: NonNegative Int -> Bool
413 prop_replicateA (NonNegative m) =
414 traverse toList' (replicateA n a) ~= sequenceA (Prelude.replicate n a)
415 where
416 n = m `mod` 10000
417 a = Action 1 0 :: M Int
418
419 prop_replicateM :: NonNegative Int -> Bool
420 prop_replicateM (NonNegative m) =
421 traverse toList' (replicateM n a) ~= sequence (Prelude.replicate n a)
422 where
423 n = m `mod` 10000
424 a = Action 1 0 :: M Int
425
426 -- ** Iterative construction
427
428 prop_iterateN :: NonNegative Int -> Int -> Bool
429 prop_iterateN (NonNegative m) x =
430 toList' (iterateN n f x) ~= Prelude.take n (Prelude.iterate f x)
431 where
432 n = m `mod` 10000
433 f = (+1)
434
435 prop_unfoldr :: [A] -> Bool
436 prop_unfoldr z =
437 toList' (unfoldr f z) ~= Data.List.unfoldr f z
438 where
439 f [] = Nothing
440 f (x:xs) = Just (x, xs)
441
442 prop_unfoldl :: [A] -> Bool
443 prop_unfoldl z =
444 toList' (unfoldl f z) ~= Data.List.reverse (Data.List.unfoldr (fmap swap . f) z)
445 where
446 f [] = Nothing
447 f (x:xs) = Just (xs, x)
448 swap (x,y) = (y,x)
449
450 -- * Deconstruction
451
452 -- ** Queries
453
454 prop_null :: Seq A -> Bool
455 prop_null xs =
456 null xs == Prelude.null (toList xs)
457
458 prop_length :: Seq A -> Bool
459 prop_length xs =
460 length xs == Prelude.length (toList xs)
461
462 -- ** Views
463
464 prop_viewl :: Seq A -> Bool
465 prop_viewl xs =
466 case viewl xs of
467 EmptyL -> Prelude.null (toList xs)
468 x :< xs' -> valid xs' && toList xs == x : toList xs'
469
470 prop_viewr :: Seq A -> Bool
471 prop_viewr xs =
472 case viewr xs of
473 EmptyR -> Prelude.null (toList xs)
474 xs' :> x -> valid xs' && toList xs == toList xs' ++ [x]
475
476 -- * Scans
477
478 prop_scanl :: [A] -> Seq A -> Bool
479 prop_scanl z xs =
480 toList' (scanl f z xs) ~= Data.List.scanl f z (toList xs)
481 where f = flip (:)
482
483 prop_scanl1 :: Seq Int -> Property
484 prop_scanl1 xs =
485 not (null xs) ==> toList' (scanl1 f xs) ~= Data.List.scanl1 f (toList xs)
486 where f = (-)
487
488 prop_scanr :: [A] -> Seq A -> Bool
489 prop_scanr z xs =
490 toList' (scanr f z xs) ~= Data.List.scanr f z (toList xs)
491 where f = (:)
492
493 prop_scanr1 :: Seq Int -> Property
494 prop_scanr1 xs =
495 not (null xs) ==> toList' (scanr1 f xs) ~= Data.List.scanr1 f (toList xs)
496 where f = (-)
497
498 -- * Sublists
499
500 prop_tails :: Seq A -> Bool
501 prop_tails xs =
502 toListList' (tails xs) ~= Data.List.tails (toList xs)
503
504 prop_inits :: Seq A -> Bool
505 prop_inits xs =
506 toListList' (inits xs) ~= Data.List.inits (toList xs)
507
508 -- ** Sequential searches
509 -- We use predicates with varying density.
510
511 prop_takeWhileL :: Positive Int -> Seq Int -> Bool
512 prop_takeWhileL (Positive n) xs =
513 toList' (takeWhileL p xs) ~= Prelude.takeWhile p (toList xs)
514 where p x = x `mod` n == 0
515
516 prop_takeWhileR :: Positive Int -> Seq Int -> Bool
517 prop_takeWhileR (Positive n) xs =
518 toList' (takeWhileR p xs) ~= Prelude.reverse (Prelude.takeWhile p (Prelude.reverse (toList xs)))
519 where p x = x `mod` n == 0
520
521 prop_dropWhileL :: Positive Int -> Seq Int -> Bool
522 prop_dropWhileL (Positive n) xs =
523 toList' (dropWhileL p xs) ~= Prelude.dropWhile p (toList xs)
524 where p x = x `mod` n == 0
525
526 prop_dropWhileR :: Positive Int -> Seq Int -> Bool
527 prop_dropWhileR (Positive n) xs =
528 toList' (dropWhileR p xs) ~= Prelude.reverse (Prelude.dropWhile p (Prelude.reverse (toList xs)))
529 where p x = x `mod` n == 0
530
531 prop_spanl :: Positive Int -> Seq Int -> Bool
532 prop_spanl (Positive n) xs =
533 toListPair' (spanl p xs) ~= Data.List.span p (toList xs)
534 where p x = x `mod` n == 0
535
536 prop_spanr :: Positive Int -> Seq Int -> Bool
537 prop_spanr (Positive n) xs =
538 toListPair' (spanr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.span p (Prelude.reverse (toList xs)))
539 where p x = x `mod` n == 0
540
541 prop_breakl :: Positive Int -> Seq Int -> Bool
542 prop_breakl (Positive n) xs =
543 toListPair' (breakl p xs) ~= Data.List.break p (toList xs)
544 where p x = x `mod` n == 0
545
546 prop_breakr :: Positive Int -> Seq Int -> Bool
547 prop_breakr (Positive n) xs =
548 toListPair' (breakr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.break p (Prelude.reverse (toList xs)))
549 where p x = x `mod` n == 0
550
551 prop_partition :: Positive Int -> Seq Int -> Bool
552 prop_partition (Positive n) xs =
553 toListPair' (partition p xs) ~= Data.List.partition p (toList xs)
554 where p x = x `mod` n == 0
555
556 prop_filter :: Positive Int -> Seq Int -> Bool
557 prop_filter (Positive n) xs =
558 toList' (filter p xs) ~= Prelude.filter p (toList xs)
559 where p x = x `mod` n == 0
560
561 -- * Sorting
562
563 prop_sort :: Seq OrdA -> Bool
564 prop_sort xs =
565 toList' (sort xs) ~= Data.List.sort (toList xs)
566
567 data UnstableOrd = UnstableOrd
568 { ordKey :: OrdA
569 , _ignored :: A
570 } deriving (Show)
571
572 instance Eq UnstableOrd where
573 x == y = compare x y == EQ
574
575 instance Ord UnstableOrd where
576 compare (UnstableOrd x _) (UnstableOrd y _) = compare x y
577
578 instance Arbitrary UnstableOrd where
579 arbitrary = liftA2 UnstableOrd arbitrary arbitrary
580 shrink (UnstableOrd x y) =
581 [ UnstableOrd x' y'
582 | (x',y') <- shrink (x, y) ]
583
584 prop_sortStable :: Seq UnstableOrd -> Bool
585 prop_sortStable xs =
586 (fmap . fmap) unignore (toList' (sort xs)) ~=
587 fmap unignore (Data.List.sort (toList xs))
588 where
589 unignore (UnstableOrd x y) = (x, y)
590
591 prop_sortBy :: Seq (OrdA, B) -> Bool
592 prop_sortBy xs =
593 toList' (sortBy f xs) ~= Data.List.sortBy f (toList xs)
594 where f (x1, _) (x2, _) = compare x1 x2
595
596 prop_sortOn :: Fun A OrdB -> Seq A -> Bool
597 prop_sortOn (Fun _ f) xs =
598 toList' (sortOn f xs) ~= listSortOn f (toList xs)
599 where
600 #if MIN_VERSION_base(4,8,0)
601 listSortOn = Data.List.sortOn
602 #else
603 listSortOn k = Data.List.sortBy (compare `on` k)
604 #endif
605
606 prop_sortOnStable :: Fun A UnstableOrd -> Seq A -> Bool
607 prop_sortOnStable (Fun _ f) xs =
608 toList' (sortOn f xs) ~= listSortOn f (toList xs)
609 where
610 #if MIN_VERSION_base(4,8,0)
611 listSortOn = Data.List.sortOn
612 #else
613 listSortOn k = Data.List.sortBy (compare `on` k)
614 #endif
615
616 prop_unstableSort :: Seq OrdA -> Bool
617 prop_unstableSort xs =
618 toList' (unstableSort xs) ~= Data.List.sort (toList xs)
619
620 prop_unstableSortBy :: Seq OrdA -> Bool
621 prop_unstableSortBy xs =
622 toList' (unstableSortBy compare xs) ~= Data.List.sort (toList xs)
623
624 prop_unstableSortOn :: Fun A OrdB -> Seq A -> Property
625 prop_unstableSortOn (Fun _ f) xs =
626 toList' (unstableSortBy (compare `on` f) xs) === toList' (unstableSortOn f xs)
627
628 -- * Indexing
629
630 prop_index :: Seq A -> Property
631 prop_index xs =
632 not (null xs) ==> forAll (choose (0, length xs-1)) $ \ i ->
633 index xs i == toList xs !! i
634
635 prop_safeIndex :: Seq A -> Property
636 prop_safeIndex xs =
637 forAll (choose (-3, length xs + 3)) $ \i ->
638 ((i < 0 || i >= length xs) .&&. lookup i xs === Nothing) .||.
639 lookup i xs === Just (toList xs !! i)
640
641 prop_insertAt :: A -> Seq A -> Property
642 prop_insertAt x xs =
643 forAll (choose (-3, length xs + 3)) $ \i ->
644 let res = insertAt i x xs
645 in valid res .&&. res === case splitAt i xs of (front, back) -> front >< x <| back
646
647 prop_deleteAt :: Seq A -> Property
648 prop_deleteAt xs =
649 forAll (choose (-3, length xs + 3)) $ \i ->
650 let res = deleteAt i xs
651 in valid res .&&.
652 (((0 <= i && i < length xs) .&&. res === case splitAt i xs of (front, back) -> front >< drop 1 back)
653 .||. ((i < 0 || i >= length xs) .&&. res === xs))
654
655 prop_adjust :: Int -> Int -> Seq Int -> Bool
656 prop_adjust n i xs =
657 toList' (adjust f i xs) ~= adjustList f i (toList xs)
658 where f = (+n)
659
660 prop_update :: Int -> A -> Seq A -> Bool
661 prop_update i x xs =
662 toList' (update i x xs) ~= adjustList (const x) i (toList xs)
663
664 prop_take :: Int -> Seq A -> Bool
665 prop_take n xs =
666 toList' (take n xs) ~= Prelude.take n (toList xs)
667
668 prop_drop :: Int -> Seq A -> Bool
669 prop_drop n xs =
670 toList' (drop n xs) ~= Prelude.drop n (toList xs)
671
672 prop_splitAt :: Int -> Seq A -> Bool
673 prop_splitAt n xs =
674 toListPair' (splitAt n xs) ~= Prelude.splitAt n (toList xs)
675
676 prop_chunksOf :: Seq A -> Property
677 prop_chunksOf xs =
678 forAll (choose (1, length xs + 3)) $ \n ->
679 let chunks = chunksOf n xs
680 in valid chunks .&&.
681 conjoin [valid c .&&. 1 <= length c && length c <= n | c <- toList chunks] .&&.
682 fold chunks === xs
683
684 adjustList :: (a -> a) -> Int -> [a] -> [a]
685 adjustList f i xs =
686 [if j == i then f x else x | (j, x) <- Prelude.zip [0..] xs]
687
688 -- ** Indexing with predicates
689 -- The elem* tests have poor coverage, but for find* we use predicates
690 -- of varying density.
691
692 prop_elemIndexL :: A -> Seq A -> Bool
693 prop_elemIndexL x xs =
694 elemIndexL x xs == Data.List.elemIndex x (toList xs)
695
696 prop_elemIndicesL :: A -> Seq A -> Bool
697 prop_elemIndicesL x xs =
698 elemIndicesL x xs == Data.List.elemIndices x (toList xs)
699
700 prop_elemIndexR :: A -> Seq A -> Bool
701 prop_elemIndexR x xs =
702 elemIndexR x xs == listToMaybe (Prelude.reverse (Data.List.elemIndices x (toList xs)))
703
704 prop_elemIndicesR :: A -> Seq A -> Bool
705 prop_elemIndicesR x xs =
706 elemIndicesR x xs == Prelude.reverse (Data.List.elemIndices x (toList xs))
707
708 prop_findIndexL :: Positive Int -> Seq Int -> Bool
709 prop_findIndexL (Positive n) xs =
710 findIndexL p xs == Data.List.findIndex p (toList xs)
711 where p x = x `mod` n == 0
712
713 prop_findIndicesL :: Positive Int -> Seq Int -> Bool
714 prop_findIndicesL (Positive n) xs =
715 findIndicesL p xs == Data.List.findIndices p (toList xs)
716 where p x = x `mod` n == 0
717
718 prop_findIndexR :: Positive Int -> Seq Int -> Bool
719 prop_findIndexR (Positive n) xs =
720 findIndexR p xs == listToMaybe (Prelude.reverse (Data.List.findIndices p (toList xs)))
721 where p x = x `mod` n == 0
722
723 prop_findIndicesR :: Positive Int -> Seq Int -> Bool
724 prop_findIndicesR (Positive n) xs =
725 findIndicesR p xs == Prelude.reverse (Data.List.findIndices p (toList xs))
726 where p x = x `mod` n == 0
727
728 -- * Folds
729
730 prop_foldlWithIndex :: [(Int, A)] -> Seq A -> Bool
731 prop_foldlWithIndex z xs =
732 foldlWithIndex f z xs == Data.List.foldl (uncurry . f) z (Data.List.zip [0..] (toList xs))
733 where f ys n y = (n,y):ys
734
735 prop_foldrWithIndex :: [(Int, A)] -> Seq A -> Bool
736 prop_foldrWithIndex z xs =
737 foldrWithIndex f z xs == Data.List.foldr (uncurry f) z (Data.List.zip [0..] (toList xs))
738 where f n y ys = (n,y):ys
739
740 prop_foldMapWithIndexL :: (Fun (B, Int, A) B) -> B -> Seq A -> Bool
741 prop_foldMapWithIndexL (Fun _ f) z t = foldlWithIndex f' z t ==
742 appEndo (getDual (foldMapWithIndex (\i -> Dual . Endo . flip (flip f' i)) t)) z
743 where f' b i a = f (b, i, a)
744
745 prop_foldMapWithIndexR :: (Fun (Int, A, B) B) -> B -> Seq A -> Bool
746 prop_foldMapWithIndexR (Fun _ f) z t = foldrWithIndex f' z t ==
747 appEndo (foldMapWithIndex (\i -> Endo . f' i) t) z
748 where f' i a b = f (i, a, b)
749
750 -- * Transformations
751
752 prop_mapWithIndex :: Seq A -> Bool
753 prop_mapWithIndex xs =
754 toList' (mapWithIndex f xs) ~= map (uncurry f) (Data.List.zip [0..] (toList xs))
755 where f = (,)
756
757 prop_traverseWithIndex :: Seq Int -> Bool
758 prop_traverseWithIndex xs =
759 runState (traverseWithIndex (\i x -> modify ((i,x) :)) xs) [] ==
760 runState (sequenceA . mapWithIndex (\i x -> modify ((i,x) :)) $ xs) []
761
762 prop_reverse :: Seq A -> Bool
763 prop_reverse xs =
764 toList' (reverse xs) ~= Prelude.reverse (toList xs)
765
766 -- ** Zips
767
768 prop_zip :: Seq A -> Seq B -> Bool
769 prop_zip xs ys =
770 toList' (zip xs ys) ~= Prelude.zip (toList xs) (toList ys)
771
772 prop_zipWith :: Seq A -> Seq B -> Bool
773 prop_zipWith xs ys =
774 toList' (zipWith f xs ys) ~= Prelude.zipWith f (toList xs) (toList ys)
775 where f = (,)
776
777 prop_zip3 :: Seq A -> Seq B -> Seq C -> Bool
778 prop_zip3 xs ys zs =
779 toList' (zip3 xs ys zs) ~= Prelude.zip3 (toList xs) (toList ys) (toList zs)
780
781 prop_zipWith3 :: Seq A -> Seq B -> Seq C -> Bool
782 prop_zipWith3 xs ys zs =
783 toList' (zipWith3 f xs ys zs) ~= Prelude.zipWith3 f (toList xs) (toList ys) (toList zs)
784 where f = (,,)
785
786 prop_zip4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool
787 prop_zip4 xs ys zs ts =
788 toList' (zip4 xs ys zs ts) ~= Data.List.zip4 (toList xs) (toList ys) (toList zs) (toList ts)
789
790 prop_zipWith4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool
791 prop_zipWith4 xs ys zs ts =
792 toList' (zipWith4 f xs ys zs ts) ~= Data.List.zipWith4 f (toList xs) (toList ys) (toList zs) (toList ts)
793 where f = (,,,)
794
795 -- This comes straight from the MonadZip documentation
796 prop_mzipNaturality :: Fun A C -> Fun B D -> Seq A -> Seq B -> Property
797 prop_mzipNaturality f g sa sb =
798 fmap (apply f *** apply g) (mzip sa sb) ===
799 mzip (apply f <$> sa) (apply g <$> sb)
800
801 -- This is a slight optimization of the MonadZip preservation
802 -- law that works because sequences don't have any decorations.
803 prop_mzipPreservation :: Fun A B -> Seq A -> Property
804 prop_mzipPreservation f sa =
805 let sb = fmap (apply f) sa
806 in munzip (mzip sa sb) === (sa, sb)
807
808 -- We want to ensure that
809 --
810 -- munzip xs = xs `seq` (fmap fst x, fmap snd x)
811 --
812 -- even in the presence of bottoms (alternatives are all balance-
813 -- fragile).
814 prop_munzipLazy :: Seq (Integer, B) -> Bool
815 prop_munzipLazy pairs = deepseq ((`seq` ()) <$> repaired) True
816 where
817 partialpairs = mapWithIndex (\i a -> update i err pairs) pairs
818 firstPieces = fmap (fst . munzip) partialpairs
819 repaired = mapWithIndex (\i s -> update i 10000 s) firstPieces
820 err = error "munzip isn't lazy enough"
821
822 -- Applicative operations
823
824 prop_ap :: Seq A -> Seq B -> Bool
825 prop_ap xs ys =
826 toList' ((,) <$> xs <*> ys) ~= ( (,) <$> toList xs <*> toList ys )
827
828 prop_ap_NOINLINE :: Seq A -> Seq B -> Bool
829 prop_ap_NOINLINE xs ys =
830 toList' (((,) <$> xs) `apNOINLINE` ys) ~= ( (,) <$> toList xs <*> toList ys )
831
832 {-# NOINLINE apNOINLINE #-}
833 apNOINLINE :: Seq (a -> b) -> Seq a -> Seq b
834 apNOINLINE fs xs = fs <*> xs
835
836 prop_liftA2 :: Seq A -> Seq B -> Property
837 prop_liftA2 xs ys = valid q .&&.
838 toList q === liftA2 (,) (toList xs) (toList ys)
839 where
840 q = liftA2 (,) xs ys
841
842 prop_then :: Seq A -> Seq B -> Bool
843 prop_then xs ys =
844 toList' (xs *> ys) ~= (toList xs *> toList ys)
845
846 prop_intersperse :: A -> Seq A -> Bool
847 prop_intersperse x xs =
848 toList' (intersperse x xs) ~= Data.List.intersperse x (toList xs)
849
850 prop_cycleTaking :: Int -> Seq A -> Property
851 prop_cycleTaking n xs =
852 (n <= 0 || not (null xs)) ==> toList' (cycleTaking n xs) ~= Data.List.take n (Data.List.cycle (toList xs))
853
854 #if __GLASGOW_HASKELL__ >= 800
855 prop_empty_pat :: Seq A -> Bool
856 prop_empty_pat xs@Empty = null xs
857 prop_empty_pat xs = not (null xs)
858
859 prop_empty_con :: Bool
860 prop_empty_con = null Empty
861
862 prop_viewl_pat :: Seq A -> Property
863 prop_viewl_pat xs@(y :<| ys)
864 | z :< zs <- viewl xs = y === z .&&. ys === zs
865 | otherwise = property failed
866 prop_viewl_pat xs = property . liftBool $ null xs
867
868 prop_viewl_con :: A -> Seq A -> Property
869 prop_viewl_con x xs = x :<| xs === x <| xs
870
871 prop_viewr_pat :: Seq A -> Property
872 prop_viewr_pat xs@(ys :|> y)
873 | zs :> z <- viewr xs = y === z .&&. ys === zs
874 | otherwise = property failed
875 prop_viewr_pat xs = property . liftBool $ null xs
876
877 prop_viewr_con :: Seq A -> A -> Property
878 prop_viewr_con xs x = xs :|> x === xs |> x
879 #endif
880
881 -- Monad operations
882
883 prop_bind :: Seq A -> Fun A (Seq B) -> Bool
884 prop_bind xs (Fun _ f) =
885 toList' (xs >>= f) ~= (toList xs >>= toList . f)
886
887 -- Semigroup operations
888
889 #if MIN_VERSION_base(4,9,0)
890 prop_stimes :: NonNegative Int -> Seq A -> Property
891 prop_stimes (NonNegative n) s =
892 stimes n s === stimesMonoid n s
893 #endif
894
895 -- MonadFix operation
896
897 -- It's exceedingly difficult to construct a proper QuickCheck
898 -- property for mfix because the function passed to it must be
899 -- lazy. The following property is really just a unit test in
900 -- disguise, and not a terribly meaningful one.
901 test_mfix :: Property
902 test_mfix = toList resS === resL
903 where
904 facty :: (Int -> Int) -> Int -> Int
905 facty _ 0 = 1; facty f n = n * f (n - 1)
906
907 resS :: Seq Int
908 resS = fmap ($ 12) $ mfix (\f -> fromList [facty f, facty (+1), facty (+2)])
909
910 resL :: [Int]
911 resL = fmap ($ 12) $ mfix (\f -> [facty f, facty (+1), facty (+2)])
912
913 -- Simple test monad
914
915 data M a = Action Int a
916 deriving (Eq, Show)
917
918 instance Functor M where
919 fmap f (Action n x) = Action n (f x)
920
921 instance Applicative M where
922 pure x = Action 0 x
923 Action m f <*> Action n x = Action (m+n) (f x)
924
925 instance Monad M where
926 return x = Action 0 x
927 Action m x >>= f = let Action n y = f x in Action (m+n) y
928
929 instance Foldable M where
930 foldMap f (Action _ x) = f x
931
932 instance Traversable M where
933 traverse f (Action n x) = Action n <$> f x