module Hedgehog.Optics
( wellFormedPrism, wellFormedLens, wellFormedIso
, prismExample
) where
import Control.Monad (Monad (return))
import Data.Either (Either (Left, Right))
import Data.Eq (Eq)
import Data.Function ((.))
import Data.Maybe (Maybe (Just))
import Hedgehog (Gen, PropertyT, annotate, forAll, (===))
import Optics.AffineFold (preview)
import Optics.AffineTraversal (matching)
import Optics.Getter (view)
import Optics.Iso (Iso')
import Optics.Lens (Lens')
import Optics.Prism (Prism')
import Optics.Review (review)
import Optics.Setter (set)
import Text.Show (Show)
wellFormedPrism :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen large -> Gen small
-> Prism' large small
-> PropertyT m ()
wellFormedPrism :: Gen large -> Gen small -> Prism' large small -> PropertyT m ()
wellFormedPrism Gen large
genLarge Gen small
genSmall Prism' large small
o =
do
Gen large -> Prism' large small -> PropertyT m ()
forall (m :: * -> *) large small.
(Monad m, Show large, Eq large, Show small, Eq small) =>
Gen large -> Prism' large small -> PropertyT m ()
getSetPrismLaw Gen large
genLarge Prism' large small
o
Gen small -> Prism' large small -> PropertyT m ()
forall (m :: * -> *) large small.
(Monad m, Show large, Eq large, Show small, Eq small) =>
Gen small -> Prism' large small -> PropertyT m ()
setGetPrismLaw Gen small
genSmall Prism' large small
o
getSetPrismLaw :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen large -> Prism' large small -> PropertyT m ()
getSetPrismLaw :: Gen large -> Prism' large small -> PropertyT m ()
getSetPrismLaw Gen large
genLarge Prism' large small
o =
do
large
large <- Gen large -> PropertyT m large
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen large
genLarge
case Prism' large small -> large -> Either large small
forall k (is :: IxList) s t a b.
Is k An_AffineTraversal =>
Optic k is s t a b -> s -> Either t a
matching Prism' large small
o large
large of
Right small
small ->
do
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The get-set law must hold for a Prism"
Prism' large small -> small -> large
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Prism' large small
o small
small large -> large -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== large
large
Left large
_ -> () -> PropertyT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setGetPrismLaw :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen small -> Prism' large small -> PropertyT m ()
setGetPrismLaw :: Gen small -> Prism' large small -> PropertyT m ()
setGetPrismLaw Gen small
genSmall Prism' large small
o =
do
small
small <- Gen small -> PropertyT m small
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen small
genSmall
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The set-get law must hold for a Prism"
Prism' large small -> large -> Either large small
forall k (is :: IxList) s t a b.
Is k An_AffineTraversal =>
Optic k is s t a b -> s -> Either t a
matching Prism' large small
o (Prism' large small -> small -> large
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Prism' large small
o small
small) Either large small -> Either large small -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== small -> Either large small
forall a b. b -> Either a b
Right small
small
wellFormedLens :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen large -> Gen small
-> Lens' large small
-> PropertyT m ()
wellFormedLens :: Gen large -> Gen small -> Lens' large small -> PropertyT m ()
wellFormedLens Gen large
genLarge Gen small
genSmall Lens' large small
o =
do
Gen large -> Gen small -> Lens' large small -> PropertyT m ()
forall (m :: * -> *) large small.
(Monad m, Show large, Eq large, Show small, Eq small) =>
Gen large -> Gen small -> Lens' large small -> PropertyT m ()
getPutLensLaw Gen large
genLarge Gen small
genSmall Lens' large small
o
Gen large -> Lens' large small -> PropertyT m ()
forall (m :: * -> *) large small.
(Monad m, Show large, Eq large, Show small, Eq small) =>
Gen large -> Lens' large small -> PropertyT m ()
putGetLensLaw Gen large
genLarge Lens' large small
o
Gen large -> Gen small -> Lens' large small -> PropertyT m ()
forall (m :: * -> *) large small.
(Monad m, Show large, Eq large, Show small, Eq small) =>
Gen large -> Gen small -> Lens' large small -> PropertyT m ()
putPutLensLaw Gen large
genLarge Gen small
genSmall Lens' large small
o
getPutLensLaw :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen large -> Gen small -> Lens' large small
-> PropertyT m ()
getPutLensLaw :: Gen large -> Gen small -> Lens' large small -> PropertyT m ()
getPutLensLaw Gen large
genLarge Gen small
genSmall Lens' large small
o =
do
large
large <- Gen large -> PropertyT m large
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen large
genLarge
small
small <- Gen small -> PropertyT m small
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen small
genSmall
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The set-get law must hold for a Lens"
Lens' large small -> large -> small
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' large small
o (Lens' large small -> small -> large -> large
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' large small
o small
small large
large) small -> small -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== small
small
putGetLensLaw :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen large -> Lens' large small -> PropertyT m ()
putGetLensLaw :: Gen large -> Lens' large small -> PropertyT m ()
putGetLensLaw Gen large
genLarge Lens' large small
o =
do
large
large <- Gen large -> PropertyT m large
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen large
genLarge
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The get-set law must hold for a Lens"
Lens' large small -> small -> large -> large
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' large small
o (Lens' large small -> large -> small
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' large small
o large
large) large
large large -> large -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== large
large
putPutLensLaw :: Monad m => (Show large, Eq large) =>
(Show small, Eq small) =>
Gen large -> Gen small -> Lens' large small
-> PropertyT m ()
putPutLensLaw :: Gen large -> Gen small -> Lens' large small -> PropertyT m ()
putPutLensLaw Gen large
genLarge Gen small
genSmall Lens' large small
o =
do
large
large <- Gen large -> PropertyT m large
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen large
genLarge
small
small1 <- Gen small -> PropertyT m small
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen small
genSmall
small
small2 <- Gen small -> PropertyT m small
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen small
genSmall
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The set-set law must hold for a Lens"
Lens' large small -> small -> large -> large
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' large small
o small
small2 (Lens' large small -> small -> large -> large
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' large small
o small
small1 large
large) large -> large -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Lens' large small -> small -> large -> large
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' large small
o small
small2 large
large
wellFormedIso :: Monad m => (Show a, Eq a) =>
(Show b, Eq b) =>
Gen a -> Gen b
-> Iso' a b
-> PropertyT m ()
wellFormedIso :: Gen a -> Gen b -> Iso' a b -> PropertyT m ()
wellFormedIso Gen a
genA Gen b
genB Iso' a b
o =
do
Gen b -> Iso' a b -> PropertyT m ()
forall (m :: * -> *) a b.
(Monad m, Show a, Eq a, Show b, Eq b) =>
Gen b -> Iso' a b -> PropertyT m ()
setGetIsoLaw Gen b
genB Iso' a b
o
Gen a -> Iso' a b -> PropertyT m ()
forall (m :: * -> *) a b.
(Monad m, Show a, Eq a, Show b, Eq b) =>
Gen a -> Iso' a b -> PropertyT m ()
getSetIsoLaw Gen a
genA Iso' a b
o
setGetIsoLaw :: Monad m => (Show a, Eq a) =>
(Show b, Eq b) =>
Gen b -> Iso' a b -> PropertyT m ()
setGetIsoLaw :: Gen b -> Iso' a b -> PropertyT m ()
setGetIsoLaw Gen b
genB Iso' a b
o =
do
b
b <- Gen b -> PropertyT m b
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen b
genB
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The set-get law must hold for an Iso"
(Iso' a b -> a -> b
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' a b
o (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' a b -> b -> a
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' a b
o) b
b b -> b -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== b
b
getSetIsoLaw :: Monad m => (Show a, Eq a) =>
(Show b, Eq b) =>
Gen a -> Iso' a b -> PropertyT m ()
getSetIsoLaw :: Gen a -> Iso' a b -> PropertyT m ()
getSetIsoLaw Gen a
genA Iso' a b
o =
do
a
a <- Gen a -> PropertyT m a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
genA
String -> PropertyT m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"The get-set law must hold for an Iso"
(Iso' a b -> b -> a
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' a b
o (b -> a) -> (a -> b) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' a b -> a -> b
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' a b
o) a
a a -> a -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
a
prismExample ::
Monad m =>
(Show large, Eq large) =>
(Show small, Eq small) =>
Prism' large small
-> large
-> small
-> PropertyT m ()
prismExample :: Prism' large small -> large -> small -> PropertyT m ()
prismExample Prism' large small
o large
large small
small =
do
Prism' large small -> small -> large
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Prism' large small
o small
small large -> large -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== large
large
Prism' large small -> large -> Maybe small
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Prism' large small
o large
large Maybe small -> Maybe small -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== small -> Maybe small
forall a. a -> Maybe a
Just small
small