packages feed

validation 0.6.0 → 0.6.1

raw patch · 7 files changed

+367/−116 lines, 7 filesdep +HUnitdep +hedgehogdep +validationdep −QuickCheckdep −cabal-doctestdep −directorydep ~basedep ~bifunctorsdep ~lenssetup-changed

Dependencies added: HUnit, hedgehog, validation

Dependencies removed: QuickCheck, cabal-doctest, directory, doctest, filepath, template-haskell

Dependency ranges changed: base, bifunctors, lens, semigroupoids, semigroups

Files

Setup.hs view
@@ -1,25 +1,2 @@-{-# LANGUAGE CPP #-}--module Main where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif---#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest (defaultMainWithDoctests)--main :: IO ()-main = defaultMainWithDoctests "doctests"--#else- import Distribution.Simple--main :: IO () main = defaultMain--#endif-
changelog view
@@ -1,3 +1,7 @@+0.6.1++* Add validate, validationnel, fromEither, liftError, validation, toEither, orElse, valueOr, ensure, codiagonal, revalidate+ 0.6.0  * Delete `Validation`, `ValidationB`, `ValidationT`, `Validation'`
src/Data/Validation.hs view
@@ -2,34 +2,56 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} --- | Data types similar to @Data.Either@ that are explicit about failure and success.+-- | A data type similar to @Data.Either@ that accumulates failures. module Data.Validation (-  -- * Data types+  -- * Data type   AccValidation(..)+  -- * Constructing validations+, validate+, validationNel+, fromEither+, liftError+  -- * Functions on validations+, validation+, toEither+, orElse+, valueOr+, ensure+, codiagonal   -- * Prisms+  -- | These prisms are useful for writing code which is polymorphic in its+  -- choice of Either or AccValidation. This choice can then be made later by a+  -- user, depending on their needs.+  --+  -- An example of this style of usage can be found+  -- <https://github.com/qfpl/validation/blob/master/examples/src/PolymorphicEmail.hs here> , _Failure , _Success   -- * Isomorphisms , Validate(..)+, revalidate ) where  import Control.Applicative(Applicative((<*>), pure), (<$>))+import Control.Lens (over) import Control.Lens.Getter((^.))-import Control.Lens.Iso(Swapped(..), Iso, iso)+import Control.Lens.Iso(Swapped(..), Iso, iso, from) import Control.Lens.Prism(Prism, prism) import Control.Lens.Review(( # )) 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))+import Data.Either(Either(Left, Right), either) import Data.Eq(Eq) import Data.Foldable(Foldable(foldr))-import Data.Function(id)+import Data.Function((.), ($), id) 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((<>)))@@ -37,30 +59,17 @@ import Data.Typeable(Typeable) import Prelude(Show) --- $setup--- >>> import Prelude(Num(..))--- >>> import Data.Eq(Eq(..))--- >>> import Data.String(String)--- >>> import Data.Int(Int)--- >>> import Test.QuickCheck--- >>> import Data.Either(either)--- >>> instance (Arbitrary err, Arbitrary a) => Arbitrary (AccValidation err a) where arbitrary = fmap (either (_Failure #) (_Success #)) arbitrary --- | A value of the type @err@ or @a@, however, the @Applicative@ instance--- accumulates values. This is witnessed by the @Semigroup@ context on the instance.--- /Note that there is no Monad such that ap = (<*>)./------ >>> _Success # (+1) <*> _Success # 7 :: AccValidation String Int--- AccSuccess 8+-- | An @AccValidation@ is either a value of the type @err@ or @a@, similar to 'Either'. However,+-- the 'Applicative' instance for @AccValidation@ /accumulates/ errors using a 'Semigroup' on @err@.+-- In contrast, the @Applicative@ for @Either@ returns only the first error. ----- >>> _Failure # ["f1"] <*> _Success # 7 :: AccValidation [String] Int--- AccFailure ["f1"]+-- A consequence of this is that @AccValidation@ has no 'Data.Functor.Bind.Bind' or 'Control.Monad.Monad' instance. This is because+-- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the+-- @Applicative@'s 'Control.Applicative.<*>' ----- >>> _Success # (+1) <*> _Failure # ["f2"] :: AccValidation [String] Int--- AccFailure ["f2"]+-- An example of typical usage can be found <https://github.com/qfpl/validation/blob/master/examples/src/Email.hs here>. ----- >>> _Failure # ["f1"] <*> _Failure # ["f2"] :: AccValidation [String] Int--- AccFailure ["f1","f2"] data AccValidation err a =   AccFailure err   | AccSuccess a@@ -210,9 +219,6 @@   AccSuccess a1 {-# INLINE appsAccValidation #-} --- |------ prop> ((x <> y) <> z) == (x <> (y <> z :: AccValidation [String] Int)) instance Semigroup e => Semigroup (AccValidation e a) where   (<>) =     appsAccValidation@@ -239,13 +245,6 @@   AccFailure mempty {-# INLINE emptyAccValidation #-} --- |------ prop> ((x `mappend` y) `mappend` z) == (x `mappend` (y `mappend` z :: AccValidation [String] Int))------ prop> mempty `mappend` x == (x :: AccValidation [String] Int)------ prop> x `mappend` mempty == (x :: AccValidation [String] Int) instance Monoid e => Monoid (AccValidation e a) where   mappend =     appmAccValidation@@ -265,6 +264,101 @@                            Right a -> AccSuccess a) {-# INLINE _EitherV #-} +swappedAccValidation ::+  Iso (AccValidation e a) (AccValidation f b) (AccValidation a e) (AccValidation b f)+swappedAccValidation =+  iso+    (\v -> case v of+             AccFailure e -> AccSuccess e+             AccSuccess a -> AccFailure a)+    (\v -> case v of+             AccFailure a -> AccSuccess a+             AccSuccess e -> AccFailure e)+{-# INLINE swappedAccValidation #-}++instance Swapped AccValidation where+  swapped =+    swappedAccValidation++-- | 'validate's the @a@ with the given predicate, returning @e@ if the predicate does not hold.+--+-- This can be thought of as having the less general type:+--+-- @+-- validate :: e -> (a -> Bool) -> a -> AccValidation e a+-- @+validate :: Validate v => e -> (a -> Bool) -> a -> v e a+validate e p a =+  if p a then _Success # a else _Failure # e++-- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since+-- they are a common semigroup to use.+validationNel :: Either e a -> AccValidation (NonEmpty e) a+validationNel = liftError pure++-- | Converts from 'Either' to 'AccValidation'.+fromEither :: Either e a -> AccValidation e a+fromEither = liftError id++-- | 'liftError' is useful for converting an 'Either' to an 'AccValidation'+-- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'.+liftError :: (b -> e) -> Either b a -> AccValidation e a+liftError f = either (AccFailure . f) AccSuccess++-- | 'validation' is the catamorphism for @AccValidation@.+validation :: (e -> c) -> (a -> c) -> AccValidation e a -> c+validation ec ac v = case v of+  AccFailure e -> ec e+  AccSuccess a -> ac a++-- | Converts from 'AccValidation' to 'Either'.+toEither :: AccValidation e a -> Either e a+toEither = validation Left Right++-- | @v 'orElse' a@ returns @a@ when @v@ is AccFailure, and the @a@ in @AccSuccess a@.+--+-- This can be thought of as having the less general type:+--+-- @+-- orElse :: AccValidation e a -> a -> a+-- @+orElse :: Validate v => v e a -> a -> a+orElse v a = case v ^. _AccValidation of+  AccFailure _ -> a+  AccSuccess x -> x++-- | Return the @a@ or run the given function over the @e@.+--+-- This can be thought of as having the less general type:+--+-- @+-- valueOr :: (e -> a) -> AccValidation e a -> a+-- @+valueOr :: Validate v => (e -> a) -> v e a -> a+valueOr ea v = case v ^. _AccValidation of+  AccFailure e -> ea e+  AccSuccess a -> a++-- | 'codiagonal' gets the value out of either side.+codiagonal :: AccValidation a a -> a+codiagonal = valueOr id++-- | 'ensure' leaves the validation unchanged when the predicate holds, or+-- fails with @e@ otherwise.+--+-- This can be thought of as having the less general type:+--+-- @+-- ensure :: e -> (a -> Bool) -> AccValidation e a -> AccValidation e a+-- @+ensure :: Validate v => e -> (a -> Bool) -> v e a -> v e a+ensure e p =+  over _AccValidation $ \v -> case v of+    AccFailure x -> AccFailure x+    AccSuccess a -> validate e p a++-- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic+-- to AccValidation, and hence isomorphic to Either. class Validate f where   _AccValidation ::     Iso (f e a) (f g b) (AccValidation e a) (AccValidation g b)@@ -296,12 +390,8 @@   Iso (Either e a) (Either g b) (AccValidation e a) (AccValidation g b) _EitherAccValidationIso =   iso-    (\x -> case x of-             Left e -> AccFailure e-             Right a -> AccSuccess a)-    (\x -> case x of-             AccFailure e -> Left e-             AccSuccess a -> Right a)+    fromEither+    toEither {-# INLINE _EitherAccValidationIso #-}  instance Validate Either where@@ -310,6 +400,7 @@   _Either =     id +-- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'AccValidation'. _Failure ::   Validate f =>   Prism (f e1 a) (f e2 a) e1 e2@@ -321,6 +412,7 @@              Right a -> Left (_Either # Right a)) {-# INLINE _Failure #-} +-- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'AccValidation'. _Success ::   Validate f =>   Prism (f e a) (f e b) a b@@ -332,19 +424,7 @@              Right a -> Right a) {-# INLINE _Success #-} -swappedAccValidation ::-  Iso (AccValidation e a) (AccValidation f b) (AccValidation a e) (AccValidation b f)-swappedAccValidation =-  iso-    (\v -> case v of-             AccFailure e -> AccSuccess e-             AccSuccess a -> AccFailure a)-    (\v -> case v of-             AccFailure a -> AccSuccess a-             AccSuccess e -> AccFailure e)-{-# INLINE swappedAccValidation #-}--instance Swapped AccValidation where-  swapped =-    swappedAccValidation+-- | '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 = _AccValidation . from _AccValidation
− test/doctests.hs 
@@ -1,11 +0,0 @@-module Main where--import Build_doctests (flags, pkgs, module_sources)-import Test.DocTest (doctest)--main :: IO ()-main =-  doctest args-  where-    args = flags ++ pkgs ++ module_sources-
+ test/hedgehog.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative (liftA3)+import Control.Monad (join, unless)+import Data.Semigroup ((<>))+import Data.Monoid (Monoid (mappend))+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)+import System.Exit (exitFailure)++import Data.Validation (AccValidation (AccSuccess, AccFailure))++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering++  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 $+    exitFailure++genAccValidation :: Gen e -> Gen a -> Gen (AccValidation e a)+genAccValidation e a = Gen.choice [fmap AccFailure e, fmap AccSuccess a]++testGen :: Gen (AccValidation [String] Int)+testGen =+  let range = Range.linear 1 50+      string = Gen.string range Gen.unicode+      strings = Gen.list range string+  in  genAccValidation strings Gen.enumBounded++mkAssoc :: (AccValidation [String] Int -> AccValidation [String] Int -> AccValidation [String] Int) -> Property+mkAssoc f =+  let g = forAll testGen+      assoc = \x y z -> ((x `f` y) `f` z) === (x `f` (y `f` z))+  in  property $ join (liftA3 assoc g g g)++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+
+ test/hunit.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Test.HUnit++import Prelude hiding (length)+import Control.Lens ((#))+import Data.Foldable (length)+import Data.Proxy (Proxy (Proxy))+import Data.Validation (AccValidation (AccSuccess, AccFailure), Validate, _Failure, _Success, ensure,+                        orElse, validate, validation, validationNel)++seven :: Int+seven = 7++three :: Int+three = 3++testYY :: Test+testYY =+  let subject  = _Success # (+1) <*> _Success # seven :: AccValidation String Int+      expected = AccSuccess 8+  in  TestCase (assertEqual "Success <*> Success" subject expected)++testNY :: Test+testNY =+  let subject  = _Failure # ["f1"] <*> _Success # seven :: AccValidation [String] Int+      expected = AccFailure ["f1"]+  in  TestCase (assertEqual "Failure <*> Success" subject expected)++testYN :: Test+testYN =+  let subject  = _Success # (+1) <*> _Failure # ["f2"] :: AccValidation [String] Int+      expected = AccFailure ["f2"]+  in  TestCase (assertEqual "Success <*> Failure" subject expected)++testNN :: Test+testNN =+  let subject  = _Failure # ["f1"] <*> _Failure # ["f2"] :: AccValidation [String] Int+      expected = AccFailure ["f1","f2"]+  in  TestCase (assertEqual "Failure <*> Failure" subject expected)++testValidationNel :: Test+testValidationNel =+  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+  :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => Proxy v -> Test++testEnsureLeftFalse _ =+  let subject :: v Int Int+      subject = ensure three (const False) (_Failure # seven)+  in  TestCase (assertEqual "ensure Left False" subject (_Failure # seven))++testEnsureLeftTrue _ =+  let subject :: v Int Int+      subject = ensure three (const True) (_Failure # seven)+  in  TestCase (assertEqual "ensure Left True" subject (_Failure # seven))++testEnsureRightFalse _ =+  let subject :: v Int Int+      subject = ensure three (const False) (_Success # seven)+  in  TestCase (assertEqual "ensure Right False" subject (_Failure # three))++testEnsureRightTrue _ =+  let subject :: v Int Int+      subject = ensure three (const True ) (_Success # seven)+  in  TestCase (assertEqual "ensure Right True" subject (_Success # seven))++testOrElseRight _ =+  let v :: v Int Int+      v = _Success # seven+      subject = v `orElse` three+  in  TestCase (assertEqual "orElseRight" subject seven)++testOrElseLeft _ =+  let v :: v Int Int+      v = _Failure # seven+      subject = v `orElse` three+  in  TestCase (assertEqual "orElseLeft" subject three)++testValidateTrue :: Test+testValidateTrue =+  let subject = validate three (const True) seven+      expected = AccSuccess seven+  in  TestCase (assertEqual "testValidateTrue" subject expected)++testValidateFalse :: Test+testValidateFalse =+  let subject = validate three (const True) seven+      expected = AccFailure three+  in  TestCase (assertEqual "testValidateFalse" subject expected)++tests :: Test+tests =+  let eitherP :: Proxy Either+      eitherP = Proxy+      validationP :: Proxy AccValidation+      validationP = Proxy+      generals :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => [Proxy v -> Test]+      generals =+        [ testEnsureLeftFalse+        , testEnsureLeftTrue+        , testEnsureRightFalse+        , testEnsureRightTrue+        , testOrElseLeft+        , testOrElseRight+        ]+      eithers = fmap ($ eitherP) generals+      validations = fmap ($ validationP) generals+  in  TestList $ [+    testYY+  , testYN+  , testNY+  , testNN+  , testValidationNel+  , testValidateFalse+  , testValidateTrue+  ] ++ eithers ++ validations+  where++main :: IO Counts+main = runTestTT tests+
validation.cabal view
@@ -1,5 +1,5 @@ name:               validation-version:            0.6.0+version:            0.6.1 license:            BSD3 license-file:       LICENCE author:             Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>@@ -33,9 +33,9 @@ homepage:           https://github.com/qfpl/validation bug-reports:        https://github.com/qfpl/validation/issues cabal-version:      >= 1.10-build-type:         Custom+build-type:         Simple extra-source-files: changelog-tested-with:        GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4+tested-with:        GHC==8.2.1, GHC==8.0.2, GHC==7.10.3  source-repository   head   type:             git@@ -44,12 +44,6 @@ flag                small_base   description:      Choose the new, split-up base package. -custom-setup-  setup-depends:-    base          >= 4     && <5,-    Cabal         >= 1.10,-    cabal-doctest >= 1.0.1 && <1.1- library   default-language:                     Haskell2010@@ -57,43 +51,60 @@   build-depends:                       base          >= 3   && < 5                     , mtl           >= 2.0 && < 2.3-                    , semigroups    >= 0.8-                    , semigroupoids >= 4.0-                    , bifunctors    >= 3.0-                    , lens          >= 4.0 && < 5+                    , semigroups    >= 0.8 && < 1+                    , semigroupoids >= 5   && < 6+                    , bifunctors    >= 5.1 && < 6+                    , lens          >= 4   && < 5                     , transformers  >= 0.3 && < 0.6    ghc-options:                     -Wall -  default-extensions:-                    NoImplicitPrelude-   hs-source-dirs:                     src    exposed-modules:                     Data.Validation -test-suite doctests+test-suite hedgehog   type:                     exitcode-stdio-1.0    main-is:-                    doctests.hs+                    hedgehog.hs    default-language:                     Haskell2010    build-depends:-                      base < 5 && >= 3-                    -- https://github.com/phadej/cabal-doctest/issues/19-                    , cabal-doctest >= 1.0.1 && <1.1-                    , doctest >= 0.9.7-                    , filepath >= 1.3-                    , directory >= 1.1-                    , QuickCheck >= 2.0-                    , template-haskell >= 2.8+                      base       >= 3   && < 5+                    , hedgehog   >= 0.5 && < 0.6+                    , semigroups >= 0.8 && < 1+                    , validation++  ghc-options:+                    -Wall+                    -threaded++  hs-source-dirs:+                    test++test-suite hunit+  type:+                    exitcode-stdio-1.0++  main-is:+                    hunit.hs++  default-language:+                    Haskell2010++  build-depends:+                      base       >= 3   && < 5+                    , HUnit      >= 1.5 && < 1.7+                    , lens       >= 4   && < 5+                    , semigroups >= 0.8 && < 1+                    , validation    ghc-options:                     -Wall