From be86a2b96a4ec4946d44f22d1c4dc2e056a57db3 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Tue, 11 Jun 2019 11:33:28 -0400 Subject: [PATCH 1/4] =?UTF-8?q?Don=E2=80=99t=20ignore=20mappend=20failures?= =?UTF-8?q?=20in=20validation?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously, a <> b would give success if either a or b were a success! This should not happen when doing validation. We want any errors to be propagated. Fixes #35 --- src/Data/Validation.hs | 8 ++++---- test/hunit_tests.hs | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 4 deletions(-) diff --git a/src/Data/Validation.hs b/src/Data/Validation.hs index 7e19153..6ded12a 100644 --- a/src/Data/Validation.hs +++ b/src/Data/Validation.hs @@ -164,10 +164,10 @@ appValidation :: -> Validation err a appValidation m (Failure e1) (Failure e2) = Failure (e1 `m` e2) -appValidation _ (Failure _) (Success a2) = - Success a2 -appValidation _ (Success a1) (Failure _) = - Success a1 +appValidation _ (Failure e1) (Success _) = + Failure e1 +appValidation _ (Success _) (Failure e2) = + Failure e2 appValidation _ (Success a1) (Success _) = Success a1 {-# INLINE appValidation #-} diff --git a/test/hunit_tests.hs b/test/hunit_tests.hs index 2e2340f..803df4a 100644 --- a/test/hunit_tests.hs +++ b/test/hunit_tests.hs @@ -111,6 +111,38 @@ testValidateNothing = option = Nothing :: Maybe Int in TestCase (assertEqual "testValidateFalse" subject expected) +testMappendNY :: Test +testMappendNY = + let v1 = _Failure # [three] + v2 = _Success # [seven] + subject = v1 <> v2 + expected = Failure [three] + in TestCase (assertEqual "Failure <> Success" subject expected) + +testMappendYN :: Test +testMappendYN = + let v1 = _Success # [three] + v2 = _Failure # [seven] + subject = v1 <> v2 + expected = Failure [seven] + in TestCase (assertEqual "Success <> Failure" subject expected) + +testMappendYY :: Test +testMappendYY = + let v1 = _Success # [three] + v2 = _Success # [seven] + subject = v1 <> v2 :: Validation [Int] [Int] + expected = Success [three] + in TestCase (assertEqual "Success <> Success" subject expected) + +testMappendNN :: Test +testMappendNN = + let v1 = _Failure # [three] + v2 = _Failure # [seven] + subject = v1 <> v2 :: Validation [Int] [Int] + expected = Failure [three, seven] + in TestCase (assertEqual "Failure <> Failure" subject expected) + tests :: Test tests = let eitherP :: Proxy Either @@ -138,6 +170,10 @@ tests = , testValidateNothing , testValidateJust , testValidateJust' + , testMappendNY + , testMappendYY + , testMappendNN + , testMappendYN ] ++ eithers ++ validations where From b65f6ab82445716943d5316678087cf142d43ba5 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Wed, 12 Jun 2019 12:34:24 -0400 Subject: [PATCH 2/4] Remove Monoid instance There is no good way to define a Monoid instance for Validation that retains failures. The two identity rules required for Monoid instances are: - mempty <> x = x - x <> mempty = x There is only one possible definitions of mempty that meets these requirements, and preserves errors: - mempty = Success mempty However, this would require that the Right side of Validation have a Monoid instance. Someone could add this instance with a Monoid a constaint, however, it is not so useful because the Right side is usually not a Monoid. --- src/Data/Validation.hs | 9 --------- test/hedgehog_tests.hs | 19 ------------------- 2 files changed, 28 deletions(-) diff --git a/src/Data/Validation.hs b/src/Data/Validation.hs index 6ded12a..c1f6338 100644 --- a/src/Data/Validation.hs +++ b/src/Data/Validation.hs @@ -59,7 +59,6 @@ import Data.Functor(Functor(fmap)) import Data.Functor.Alt(Alt(())) import Data.Functor.Apply(Apply((<.>))) import Data.List.NonEmpty (NonEmpty) -import Data.Monoid(Monoid(mappend, mempty)) import Data.Ord(Ord) import Data.Semigroup(Semigroup((<>))) import Data.Traversable(Traversable(traverse)) @@ -177,14 +176,6 @@ instance Semigroup e => Semigroup (Validation e a) where appValidation (<>) {-# INLINE (<>) #-} -instance Monoid e => Monoid (Validation e a) where - mappend = - appValidation mappend - {-# INLINE mappend #-} - mempty = - Failure mempty - {-# INLINE mempty #-} - instance Swapped Validation where swapped = iso diff --git a/test/hedgehog_tests.hs b/test/hedgehog_tests.hs index 3a4e6a8..60553ee 100644 --- a/test/hedgehog_tests.hs +++ b/test/hedgehog_tests.hs @@ -18,9 +18,6 @@ main = do result <- checkParallel $ Group "Validation" [ ("prop_semigroup", prop_semigroup) - , ("prop_monoid_assoc", prop_monoid_assoc) - , ("prop_monoid_left_id", prop_monoid_left_id) - , ("prop_monoid_right_id", prop_monoid_right_id) ] unless result $ @@ -44,19 +41,3 @@ mkAssoc f = prop_semigroup :: Property prop_semigroup = mkAssoc (<>) - -prop_monoid_assoc :: Property -prop_monoid_assoc = mkAssoc mappend - -prop_monoid_left_id :: Property -prop_monoid_left_id = - property $ do - x <- forAll testGen - (mempty `mappend` x) === x - -prop_monoid_right_id :: Property -prop_monoid_right_id = - property $ do - x <- forAll testGen - (x `mappend` mempty) === x - From abc97f4586be929774a97dc89805acbc0e658239 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Wed, 12 Jun 2019 12:39:46 -0400 Subject: [PATCH 3/4] Cleanup mappend tests a bit MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Don’t rely on lens # --- test/hunit_tests.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/test/hunit_tests.hs b/test/hunit_tests.hs index 803df4a..8649aea 100644 --- a/test/hunit_tests.hs +++ b/test/hunit_tests.hs @@ -113,33 +113,33 @@ testValidateNothing = testMappendNY :: Test testMappendNY = - let v1 = _Failure # [three] - v2 = _Success # [seven] + let v1 = Failure [three] + v2 = Success seven subject = v1 <> v2 expected = Failure [three] in TestCase (assertEqual "Failure <> Success" subject expected) testMappendYN :: Test testMappendYN = - let v1 = _Success # [three] - v2 = _Failure # [seven] + let v1 = Success three + v2 = Failure [seven] subject = v1 <> v2 expected = Failure [seven] in TestCase (assertEqual "Success <> Failure" subject expected) testMappendYY :: Test testMappendYY = - let v1 = _Success # [three] - v2 = _Success # [seven] - subject = v1 <> v2 :: Validation [Int] [Int] - expected = Success [three] + let v1 = Success three + v2 = Success seven + subject = v1 <> v2 :: Validation [Int] Int + expected = Success three in TestCase (assertEqual "Success <> Success" subject expected) testMappendNN :: Test testMappendNN = - let v1 = _Failure # [three] - v2 = _Failure # [seven] - subject = v1 <> v2 :: Validation [Int] [Int] + let v1 = Failure [three] + v2 = Failure [seven] + subject = v1 <> v2 :: Validation [Int] Int expected = Failure [three, seven] in TestCase (assertEqual "Failure <> Failure" subject expected) @@ -155,7 +155,7 @@ tests = , testEnsureLeftJust , testEnsureRightNothing , testEnsureRightJust - , testEnsureRightJust' + , testEnsureRightJust' , testOrElseLeft , testOrElseRight ] From a785cb13e5147db5c06537a2d36837a31f178061 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Thu, 13 Jun 2019 13:33:56 -0400 Subject: [PATCH 4/4] Suppoort pre-8.4 ghc --- test/hunit_tests.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/hunit_tests.hs b/test/hunit_tests.hs index 8649aea..67b7d23 100644 --- a/test/hunit_tests.hs +++ b/test/hunit_tests.hs @@ -9,6 +9,7 @@ import Control.Lens ((#)) import Control.Monad (when) import Data.Foldable (length) import Data.Proxy (Proxy (Proxy)) +import Data.Semigroup(Semigroup((<>))) import Data.Validation (Validation (Success, Failure), Validate, _Failure, _Success, ensure, orElse, validate, validation, validationNel) import System.Exit (exitFailure)