diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,9 @@ +4.0 +--- + +* Initial release containing the properties: + * `isIso` + * `isLens` + * `isPrism` + * `isSetter` + * `isTraversal` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lens-properties.cabal b/lens-properties.cabal new file mode 100644 --- /dev/null +++ b/lens-properties.cabal @@ -0,0 +1,32 @@ +name: lens-properties +category: Data, Lenses +version: 4.0 +license: BSD3 +cabal-version: >= 1.8 +author: Edward Kmett and Oliver Charles +maintainer: Edward Kmett +stability: provisional +homepage: http://github.com/ekmett/lens/ +bug-reports: http://github.com/ekmett/lens/issues +copyright: Copyright (C) 2012-2014 Edward A. Kmett, Copyright (C) 2014 Oliver Charles +synopsis: QuickCheck properties for lens +build-type: Simple + +extra-source-files: + CHANGELOG.markdown + +source-repository head + type: git + location: git://github.com/ekmett/lens.git + +library + build-depends: + base >= 4.3 && < 5, + lens >= 4 && < 4.1, + QuickCheck >= 2.4 && < 2.7, + transformers >= 0.2 && < 0.4 + + exposed-modules: + Control.Lens.Properties + + hs-source-dirs: src diff --git a/src/Control/Lens/Properties.hs b/src/Control/Lens/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Properties.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | A collection of properties that can be tested with QuickCheck, to guarantee +-- that you are working with valid 'Lens'es, 'Setter's, 'Traversal's, 'Iso's and +-- 'Prism's. +module Control.Lens.Properties + ( isLens + , isTraversal + , isSetter + , isIso + , isPrism + ) where + +import Control.Applicative +import Control.Lens +import Data.Functor.Compose +import Test.QuickCheck +import Test.QuickCheck.Function + +-------------------------------------------------------------------------------- +-- | A 'Setter' is only legal if the following 3 laws hold: +-- +-- 1. @set l y (set l x a) ≡ set l y a@ +-- +-- 2. @over l id ≡ id@ +-- +-- 3. @over l f . over l g ≡ over l (f . g)@ +isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) + => Simple Setter s a -> Property +isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l + + +-------------------------------------------------------------------------------- +-- | A 'Traversal' is only legal if it is a valid 'Setter' (see 'isSetter' for +-- what makes a 'Setter' valid), and the following laws hold: +-- +-- 1. @t pure ≡ pure@ +-- +-- 2. @fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)@ +isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) + => Simple Traversal s a -> Property +isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l + .&. do as <- arbitrary + bs <- arbitrary + t <- arbitrary + property $ traverse_compose l (\x -> as++[x]++bs) + (\x -> if t then Just x else Nothing) + + +-------------------------------------------------------------------------------- +-- | A 'Lens' is only legal if it is a valid 'Traversal' (see 'isTraversal' for +-- what this means), and if the following laws hold: +-- +-- 1. @view l (set l b a) ≡ b@ +-- +-- 2. @set l (view l a) a ≡ a@ +-- +-- 3. @set l c (set l b a) ≡ set l c a@ +isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) + => Simple Lens s a -> Property +isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l + + +-------------------------------------------------------------------------------- +isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a) + => Simple Iso s a -> Property +isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) + + +-------------------------------------------------------------------------------- +isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) + => Simple Prism s a -> Property +isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l + + +-------------------------------------------------------------------------------- +-- The first setter law: +setter_id :: Eq s => Simple Setter s a -> s -> Bool +setter_id l s = over l id s == s + +-- The second setter law: +setter_composition :: Eq s => Simple Setter s a -> s -> Fun a a -> Fun a a -> Bool +setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s + +lens_set_view :: Eq s => Simple Lens s a -> s -> Bool +lens_set_view l s = set l (view l s) s == s + +lens_view_set :: Eq a => Simple Lens s a -> s -> a -> Bool +lens_view_set l s a = view l (set l a s) == a + +setter_set_set :: Eq s => Simple Setter s a -> s -> a -> a -> Bool +setter_set_set l s a b = set l b (set l a s) == set l b s + +iso_hither :: Eq s => Simple AnIso s a -> s -> Bool +iso_hither l s = s ^.cloneIso l.from l == s + +iso_yon :: Eq a => Simple AnIso s a -> a -> Bool +iso_yon l a = a^.from l.cloneIso l == a + +prism_yin :: Eq a => Simple Prism s a -> a -> Bool +prism_yin l a = preview l (review l a) == Just a + +prism_yang :: Eq s => Simple Prism s a -> s -> Bool +prism_yang l s = maybe s (review l) (preview l s) == s + +traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => LensLike' f s a -> s -> Bool +traverse_pure l s = l pure s == (pure s :: f s) + +traverse_pureMaybe :: Eq s => LensLike' Maybe s a -> s -> Bool +traverse_pureMaybe = traverse_pure + +traverse_pureList :: Eq s => LensLike' [] s a -> s -> Bool +traverse_pureList = traverse_pure + +traverse_compose :: (Applicative f, Applicative g, Eq (f (g s))) + => Simple Traversal s a -> (a -> g a) -> (a -> f a) -> s -> Bool +traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s