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