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
|
{-# LANGUAGE AllowAmbiguousTypes #-}
module Legacy.Spec.Traversable ( laws )
where
import Legacy.Clothes (F, G, H, FG(..), GH(..), NatTransf(..))
import Data.Barbie (TraversableB(..))
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Maybe (maybeToList)
import Data.Typeable (Typeable, typeRep, Proxy(..))
import Test.Tasty(testGroup, TestTree)
import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))
laws
:: forall b
. ( TraversableB b
, Eq (b F), Eq (b G), Eq (b H)
, Show (b F), Show (b G), Show (b H)
, Arbitrary (b F)
, Typeable b
)
=> TestTree
laws
= testGroup (show (typeRep (Proxy :: Proxy b)))
[testProperty "naturality" $
\b (FG (NatTransf fg)) ->
let f = Just . fg
t = maybeToList
in (t . btraverse f) (b :: b F) === btraverse (t . f) (b :: b F)
, testProperty "identity" $ \b ->
btraverse Identity b === Identity (b :: b F)
, testProperty "composition" $
\b (FG (NatTransf fg)) (GH (NatTransf gh)) ->
let f x = Just (fg x)
g x = [gh x]
in btraverse (Compose . fmap g . f) b ===
(Compose . fmap (btraverse g) . btraverse f) (b :: b F)
]
|
