Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Don’t ignore mappend failures in validation #39

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open

Don’t ignore mappend failures in validation #39

Show file tree
Hide file tree
Changes from 3 commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
be86a2b
Don’t ignore mappend failures in validation
matthewbauer Jun 11, 2019
b65f6ab
Remove Monoid instance
matthewbauer Jun 12, 2019
abc97f4
Cleanup mappend tests a bit
matthewbauer Jun 12, 2019
a785cb1
Suppoort pre-8.4 ghc
matthewbauer Jun 13, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 4 additions & 13 deletions src/Data/Validation.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -164,10 +163,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
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This case is still awkward. Why drop the right side here?

{-# INLINE appValidation #-}
Expand All @@ -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
Expand Down
19 changes: 0 additions & 19 deletions test/hedgehog_tests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 $
Expand All @@ -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

38 changes: 37 additions & 1 deletion test/hunit_tests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -123,7 +155,7 @@ tests =
, testEnsureLeftJust
, testEnsureRightNothing
, testEnsureRightJust
, testEnsureRightJust'
, testEnsureRightJust'
, testOrElseLeft
, testOrElseRight
]
Expand All @@ -138,6 +170,10 @@ tests =
, testValidateNothing
, testValidateJust
, testValidateJust'
, testMappendNY
, testMappendYY
, testMappendNN
, testMappendYN
] ++ eithers ++ validations
where

Expand Down