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