diff --git a/changelog.txt b/changelog.txt new file mode 100644 --- /dev/null +++ b/changelog.txt @@ -0,0 +1,2 @@ +1.0.0 - Initial release +1.0.0.1 - Employ Hedgehog's 'annotate' function for better error output diff --git a/hedgehog-optics.cabal b/hedgehog-optics.cabal --- a/hedgehog-optics.cabal +++ b/hedgehog-optics.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: hedgehog-optics -version: 1.0.0 +version: 1.0.0.1 category: Testing, Optics synopsis: @@ -21,6 +21,8 @@ bug-reports: https://github.com/typeclasses/hedgehog-optics/issues build-type: Simple + +extra-source-files: changelog.txt source-repository head type: git diff --git a/src/Hedgehog/Optics.hs b/src/Hedgehog/Optics.hs --- a/src/Hedgehog/Optics.hs +++ b/src/Hedgehog/Optics.hs @@ -1,12 +1,14 @@ -module Hedgehog.Optics where +module Hedgehog.Optics + ( wellFormedPrism, wellFormedLens, wellFormedIso + , prismExample + ) where -import Control.Applicative (Applicative ((*>))) 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, forAll, (===)) +import Hedgehog (Gen, PropertyT, annotate, forAll, (===)) import Optics.AffineFold (preview) import Optics.AffineTraversal (matching) import Optics.Getter (view) @@ -19,88 +21,115 @@ {- | Checks whether a prism respects the well-formedness laws given in "Optics.Prism" -} -wellFormedPrism :: - Monad m => - (Show large, Eq large) => - (Show small, Eq small) => - - Gen large - -> Gen small +wellFormedPrism :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen large -> Gen small -> Prism' large small {- ^ Prism signifying that the @small@ type is a subset of the @large@ type -} -> PropertyT m () +wellFormedPrism genLarge genSmall o = + do + getSetPrismLaw genLarge o + setGetPrismLaw genSmall o -wellFormedPrism genLarge genSmall o = part1 *> part2 - where - part1 = - do - large <- forAll genLarge - case matching o large of - Right small -> review o small === large - Left _ -> return () +getSetPrismLaw :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen large -> Prism' large small -> PropertyT m () +getSetPrismLaw genLarge o = + do + large <- forAll genLarge + case matching o large of + Right small -> + do + annotate "The get-set law must hold for a Prism" + review o small === large + Left _ -> return () - part2 = - do - small <- forAll genSmall - matching o (review o small) === Right small +setGetPrismLaw :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen small -> Prism' large small -> PropertyT m () +setGetPrismLaw genSmall o = + do + small <- forAll genSmall + annotate "The set-get law must hold for a Prism" + matching o (review o small) === Right small {- | Checks whether a lens respects the well-formedness laws given in "Optics.Lens" -} -wellFormedLens :: - Monad m => - (Show large, Eq large) => - (Show small, Eq small) => - - Gen large - -> Gen small +wellFormedLens :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen large -> Gen small -> Lens' large small {- ^ Lens signifying that the @small@ type is a constituent part of the @large@ type -} -> PropertyT m () +wellFormedLens genLarge genSmall o = + do + getPutLensLaw genLarge genSmall o + putGetLensLaw genLarge o + putPutLensLaw genLarge genSmall o -wellFormedLens genLarge genSmall o = getPut *> putGet *> putPut - where - getPut = - do - large <- forAll genLarge - small <- forAll genSmall - view o (set o small large) === small +getPutLensLaw :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen large -> Gen small -> Lens' large small + -> PropertyT m () +getPutLensLaw genLarge genSmall o = + do + large <- forAll genLarge + small <- forAll genSmall + annotate "The set-get law must hold for a Lens" + view o (set o small large) === small - putGet = - do - large <- forAll genLarge - set o (view o large) large === large +putGetLensLaw :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen large -> Lens' large small -> PropertyT m () +putGetLensLaw genLarge o = + do + large <- forAll genLarge + annotate "The get-set law must hold for a Lens" + set o (view o large) large === large - putPut = - do - large <- forAll genLarge - small1 <- forAll genSmall - small2 <- forAll genSmall - set o small2 (set o small1 large) === set o small2 large +putPutLensLaw :: Monad m => (Show large, Eq large) => + (Show small, Eq small) => + Gen large -> Gen small -> Lens' large small + -> PropertyT m () +putPutLensLaw genLarge genSmall o = + do + large <- forAll genLarge + small1 <- forAll genSmall + small2 <- forAll genSmall + annotate "The set-set law must hold for a Lens" + set o small2 (set o small1 large) === set o small2 large {- | Checks whether an isomorphism respects the well-formedness laws given in "Optics.Iso" -} -wellFormedIso :: - Monad m => - (Show a, Eq a) => - (Show b, Eq b) => - - Gen a - -> Gen b +wellFormedIso :: Monad m => (Show a, Eq a) => + (Show b, Eq b) => + Gen a -> Gen b -> Iso' a b {- ^ Isomorphism signifying that types @a@ and @b@ are basically the same thing -} -> PropertyT m () +wellFormedIso genA genB o = + do + setGetIsoLaw genB o + getSetIsoLaw genA o -wellFormedIso genA genB o = part1 *> part2 - where - part1 = - do - b <- forAll genB - (view o . review o) b === b +setGetIsoLaw :: Monad m => (Show a, Eq a) => + (Show b, Eq b) => + Gen b -> Iso' a b -> PropertyT m () +setGetIsoLaw genB o = + do + b <- forAll genB + annotate "The set-get law must hold for an Iso" + (view o . review o) b === b - part2 = - do - a <- forAll genA - (review o . view o) a === a +getSetIsoLaw :: Monad m => (Show a, Eq a) => + (Show b, Eq b) => + Gen a -> Iso' a b -> PropertyT m () +getSetIsoLaw genA o = + do + a <- forAll genA + annotate "The get-set law must hold for an Iso" + (review o . view o) a === a {- | Assert that a prism matches for a particular set of values: A 'review' of the @small@ value should produce the @large@ value, and