1{-# LANGUAGE CPP #-}
2{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE LiberalTypeSynonyms #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5-- | A collection of properties that can be tested with QuickCheck, to guarantee
6-- that you are working with valid 'Lens'es, 'Setter's, 'Traversal's, 'Iso's and
7-- 'Prism's.
8module Control.Lens.Properties
9    ( isLens
10    , isTraversal
11    , isSetter
12    , isIso
13    , isPrism
14    ) where
15
16#if !(MIN_VERSION_base(4,8,0))
17import Control.Applicative
18#endif
19import Control.Lens
20import Data.Functor.Compose
21import Test.QuickCheck
22
23--------------------------------------------------------------------------------
24-- | A 'Setter' is only legal if the following 3 laws hold:
25--
26-- 1. @set l y (set l x a) ≡ set l y a@
27--
28-- 2. @over l id ≡ id@
29--
30-- 3. @over l f . over l g ≡ over l (f . g)@
31isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a)
32         => Setter' s a -> Property
33isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l
34
35
36--------------------------------------------------------------------------------
37-- | A 'Traversal' is only legal if it is a valid 'Setter' (see 'isSetter' for
38-- what makes a 'Setter' valid), and the following laws hold:
39--
40-- 1. @t pure ≡ pure@
41--
42-- 2. @fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)@
43isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a)
44         => Traversal' s a -> Property
45isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l
46                  .&. do as <- arbitrary
47                         bs <- arbitrary
48                         t <- arbitrary
49                         return $ traverse_compose l (\x -> as++[x]++bs)
50                                                     (\x -> if t then Just x else Nothing)
51
52
53--------------------------------------------------------------------------------
54-- | A 'Lens' is only legal if it is a valid 'Traversal' (see 'isTraversal' for
55-- what this means), and if the following laws hold:
56--
57-- 1. @view l (set l b a)  ≡ b@
58--
59-- 2. @set l (view l a) a  ≡ a@
60--
61-- 3. @set l c (set l b a) ≡ set l c a@
62isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)
63       => Lens' s a -> Property
64isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l
65
66
67--------------------------------------------------------------------------------
68isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a)
69      => Iso' s a -> Property
70isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l)
71
72
73--------------------------------------------------------------------------------
74isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)
75      => Prism' s a -> Property
76isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l
77
78
79--------------------------------------------------------------------------------
80-- The first setter law:
81setter_id :: Eq s => Setter' s a -> s -> Bool
82setter_id l s = over l id s == s
83
84--  The second setter law:
85setter_composition :: Eq s => Setter' s a -> s -> Fun a a -> Fun a a -> Bool
86setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s
87
88lens_set_view :: Eq s => Lens' s a -> s -> Bool
89lens_set_view l s = set l (view l s) s == s
90
91lens_view_set :: Eq a => Lens' s a -> s -> a -> Bool
92lens_view_set l s a = view l (set l a s) == a
93
94setter_set_set :: Eq s => Setter' s a -> s -> a -> a -> Bool
95setter_set_set l s a b = set l b (set l a s) == set l b s
96
97iso_hither :: Eq s => AnIso' s a -> s -> Bool
98iso_hither l s = s ^.cloneIso l.from l == s
99
100iso_yon :: Eq a => AnIso' s a -> a -> Bool
101iso_yon l a = a^.from l.cloneIso l == a
102
103prism_yin :: Eq a => Prism' s a -> a -> Bool
104prism_yin l a = preview l (review l a) == Just a
105
106prism_yang :: Eq s => Prism' s a -> s -> Bool
107prism_yang l s = maybe s (review l) (preview l s) == s
108
109traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => LensLike' f s a -> s -> Bool
110traverse_pure l s = l pure s == (pure s :: f s)
111
112traverse_pureMaybe :: Eq s => LensLike' Maybe s a -> s -> Bool
113traverse_pureMaybe = traverse_pure
114
115traverse_pureList :: Eq s => LensLike' [] s a -> s -> Bool
116traverse_pureList = traverse_pure
117
118traverse_compose :: (Applicative f, Applicative g, Eq (f (g s)))
119                    => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool
120traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s
121