diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +1.1 + +* Generalise types of `validate` and `ensure` functions to use `Maybe` instead of `Bool` + 1 * Rename `AccValidation` to `Validation` diff --git a/src/Data/Validation.hs b/src/Data/Validation.hs --- a/src/Data/Validation.hs +++ b/src/Data/Validation.hs @@ -50,7 +50,6 @@ import Data.Bifoldable(Bifoldable(bifoldr)) import Data.Bifunctor(Bifunctor(bimap)) import Data.Bitraversable(Bitraversable(bitraverse)) -import Data.Bool (Bool) import Data.Data(Data) import Data.Either(Either(Left, Right), either) import Data.Eq(Eq) @@ -68,7 +67,7 @@ #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif -import Prelude(Show) +import Prelude(Show, Maybe(..)) -- | An @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However, @@ -114,6 +113,7 @@ (<*>) = (<.>) +-- | For two errors, this instance reports only the last of them. instance Alt (Validation err) where Failure _ x = x @@ -202,16 +202,18 @@ Failure e -> rnf e Success a -> rnf a --- | 'validate's the @a@ with the given predicate, returning @e@ if the predicate does not hold. +-- | 'validate's an @a@ producing an updated optional value, returning +-- @e@ in the empty case. -- -- This can be thought of as having the less general type: -- -- @ --- validate :: e -> (a -> Bool) -> a -> Validation e a +-- validate :: e -> (a -> Maybe b) -> a -> Validation e b -- @ -validate :: Validate v => e -> (a -> Bool) -> a -> v e a -validate e p a = - if p a then _Success # a else _Failure # e +validate :: Validate v => e -> (a -> Maybe b) -> a -> v e b +validate e p a = case p a of + Nothing -> _Failure # e + Just b -> _Success # b -- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since -- they are a common semigroup to use. @@ -265,15 +267,16 @@ codiagonal :: Validation a a -> a codiagonal = valueOr id --- | 'ensure' leaves the validation unchanged when the predicate holds, or --- fails with @e@ otherwise. +-- | 'ensure' ensures that a validation remains unchanged upon failure, +-- updating a successful validation with an optional value that could fail +-- with @e@ otherwise. -- -- This can be thought of as having the less general type: -- -- @ --- ensure :: e -> (a -> Bool) -> Validation e a -> Validation e a +-- ensure :: e -> (a -> Maybe b) -> Validation e a -> Validation e b -- @ -ensure :: Validate v => e -> (a -> Bool) -> v e a -> v e a +ensure :: Validate v => e -> (a -> Maybe b) -> v e a -> v e b ensure e p = over _Validation $ \v -> case v of Failure x -> Failure x @@ -370,4 +373,3 @@ -- | 'revalidate' converts between any two instances of 'Validate'. revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t) revalidate = _Validation . from _Validation - diff --git a/test/hunit_tests.hs b/test/hunit_tests.hs --- a/test/hunit_tests.hs +++ b/test/hunit_tests.hs @@ -19,6 +19,9 @@ three :: Int three = 3 +four :: Int +four = 4 + testYY :: Test testYY = let subject = _Success # (+1) <*> _Success # seven :: Validation String Int @@ -48,30 +51,35 @@ let subject = validation length (const 0) $ validationNel (Left ()) in TestCase (assertEqual "validationNel makes lists of length 1" subject 1) -testEnsureLeftFalse, testEnsureLeftTrue, testEnsureRightFalse, testEnsureRightTrue, - testOrElseRight, testOrElseLeft +testEnsureLeftNothing, testEnsureLeftJust, testEnsureRightNothing, + testEnsureRightJust, testEnsureRightJust', testOrElseRight, testOrElseLeft :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => Proxy v -> Test -testEnsureLeftFalse _ = +testEnsureLeftNothing _ = let subject :: v Int Int - subject = ensure three (const False) (_Failure # seven) + subject = ensure three (const Nothing) (_Failure # seven) in TestCase (assertEqual "ensure Left False" subject (_Failure # seven)) -testEnsureLeftTrue _ = +testEnsureLeftJust _ = let subject :: v Int Int - subject = ensure three (const True) (_Failure # seven) + subject = ensure three (Just . id) (_Failure # seven) in TestCase (assertEqual "ensure Left True" subject (_Failure # seven)) -testEnsureRightFalse _ = +testEnsureRightNothing _ = let subject :: v Int Int - subject = ensure three (const False) (_Success # seven) + subject = ensure three (const Nothing) (_Success # seven) in TestCase (assertEqual "ensure Right False" subject (_Failure # three)) -testEnsureRightTrue _ = +testEnsureRightJust _ = let subject :: v Int Int - subject = ensure three (const True ) (_Success # seven) + subject = ensure three (Just . id) (_Success # seven) in TestCase (assertEqual "ensure Right True" subject (_Success # seven)) +testEnsureRightJust' _ = + let subject :: v Int Int + subject = ensure three (const $ Just four) (_Success # seven) + in TestCase (assertEqual "ensure Right True" subject (_Success # four)) + testOrElseRight _ = let v :: v Int Int v = _Success # seven @@ -84,16 +92,23 @@ subject = v `orElse` three in TestCase (assertEqual "orElseLeft" subject three) -testValidateTrue :: Test -testValidateTrue = - let subject = validate three (const True) seven +testValidateJust :: Test +testValidateJust = + let subject = validate three (Just . id) seven expected = Success seven in TestCase (assertEqual "testValidateTrue" subject expected) -testValidateFalse :: Test -testValidateFalse = - let subject = validate three (const False) seven +testValidateJust' :: Test +testValidateJust' = + let subject = validate three (const $ Just four) seven + expected = Success four + in TestCase (assertEqual "testValidateTrue" subject expected) + +testValidateNothing :: Test +testValidateNothing = + let subject = validate three (const option) seven expected = Failure three + option = Nothing :: Maybe Int in TestCase (assertEqual "testValidateFalse" subject expected) tests :: Test @@ -104,10 +119,11 @@ validationP = Proxy generals :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => [Proxy v -> Test] generals = - [ testEnsureLeftFalse - , testEnsureLeftTrue - , testEnsureRightFalse - , testEnsureRightTrue + [ testEnsureLeftNothing + , testEnsureLeftJust + , testEnsureRightNothing + , testEnsureRightJust + , testEnsureRightJust' , testOrElseLeft , testOrElseRight ] @@ -119,8 +135,9 @@ , testNY , testNN , testValidationNel - , testValidateFalse - , testValidateTrue + , testValidateNothing + , testValidateJust + , testValidateJust' ] ++ eithers ++ validations where @@ -128,4 +145,3 @@ main = do c <- runTestTT tests when (errors c > 0 || failures c > 0) exitFailure - diff --git a/validation.cabal b/validation.cabal --- a/validation.cabal +++ b/validation.cabal @@ -1,12 +1,12 @@ name: validation -version: 1 +version: 1.1 license: BSD3 license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge , Queensland Functional Programming Lab copyright: Copyright (C) 2010-2013 Tony Morris, Nick Partridge Copyright (C) 2014,2015 NICTA Limited - Copyright (c) 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. + Copyright (c) 2016-2019, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. synopsis: A data-type like Either but with an accumulating Applicative category: Data description: @@ -35,7 +35,7 @@ cabal-version: >= 1.10 build-type: Simple extra-source-files: changelog -tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 source-repository head type: git @@ -76,7 +76,7 @@ build-depends: base >= 3 && < 5 - , hedgehog >= 0.5 && < 0.6 + , hedgehog >= 0.5 && < 0.7 , semigroups >= 0.8 && < 1 , validation