validation-selective (empty) → 0.0.0.0
raw patch · 10 files changed
+2142/−0 lines, 10 filesdep +basedep +deepseqdep +doctest
Dependencies added: base, deepseq, doctest, hedgehog, hspec, hspec-hedgehog, selective, text, validation-selective
Files
- CHANGELOG.md +11/−0
- LICENSE +373/−0
- README.md +104/−0
- src/Validation.hs +1144/−0
- test/Doctest.hs +26/−0
- test/Spec.hs +12/−0
- test/Test/Gen.hs +81/−0
- test/Test/Laws.hs +270/−0
- test/Test/Properties.hs +21/−0
- validation-selective.cabal +100/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`validation-selective` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.0.0.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/kowainik/validation-selective/releases
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,104 @@+# validation-selective+++[](https://github.com/kowainik/validation-selective/actions)+[](https://travis-ci.org/kowainik/validation-selective)+[](https://ci.appveyor.com/project/kowainik/validation-selective)++[](https://hackage.haskell.org/package/validation-selective)+[](http://stackage.org/lts/package/validation-selective)+[](http://stackage.org/nightly/package/validation-selective)+[](LICENSE)++Lightweight pure data validation based on `Applicative` and `Selective` functors.++`validation-selective` is built around the following data type:++```haskell+data Validation e a+ = Failure e+ | Success a+```++This data type is similar to `Either` but allows accumulating all+errors instead of short-circuiting on the first one.++For more examples and library tutorial, refer to Haddock:++* [`validation`: Official documentation](http://hackage.haskell.org/package/validation-selective/docs/Validation.html)++## Comparison with other packages++`validation-selective` is not the only package that provides such+`Validation` data type. However, unlike other packages, it has some+noticeable advantages:+++ **Lightweight**. `validation-selective` depends only on `base` and+ `selective` (which is tiny) Haskell libraries which make this+ package fast to build. So adding validation capabilities to your+ library or application doesn't contribute much to your dependency+ footprint.++ **Selective instance.** `validation-selective` is the only package+ that provides `Selective` instance for `Validation` which allows+ using `Monad`-like branching behaviour but without implementing+ wrong `Monad` instance.++ **More algebraic instances.** `validation-selective` also provides+ the `Alternative` instance and a more general `Semigroup` instance.++ **Best-in-class documentation.** Official Haddock documentation+ contains mini-tutorial, usage example, per-component comparison with+ `Either`, the motivation behind each instance and the interface in+ general along with examples for **each instance and function**.++The below section provides per-package comparison with the most+popular validation packages in the Haskell ecosystem:+++ [`either`](https://hackage.haskell.org/package/either): `Validation`+ implementation by Edward Kmett. This package is more heavyweight,+ since it depends on more Haskell libraries like `profunctors`,+ `bifunctors`, `semigroupoids`. But it also provides prisms for+ `Validation` and some combinators for `Either`.++ [`validation`](https://hackage.haskell.org/package/validation):+ `Validation` from [Queensland Functional Programming Lab](https://qfpl.io/).+ Depends on `lens`, which makes it even heavier but also have richer+ interface compared to the `either` package.++## How to use++`validation-selective` is compatible with the latest GHC compiler+versions starting from `8.4.4`.++In order to start using `validation-selective` in your project, you+will need to set it up with the three easy steps:++1. Add the dependency on `validation-selective` in your project's+ `.cabal` file. For this, you should modify the `build-depends`+ section by adding the name of this library. After the adjustment,+ this section could look like this:++ ```haskell+ build-depends: base ^>= 4.14+ , validation-selective ^>= 0.0+ ```+2. In the module where you wish to implement pure data validation, you+ should add the import:++ ```haskell+ import Validation (Validation (..))+ ```+3. Now you can use the types and functions from the library:++ ```haskell+ main :: IO ()+ main = print [Failure "wrong", Success 42]+ ```++### Usage with Stack++If `validation-selective` is not available on your current Stackage+resolver yet, fear not! You can still use it from Hackage by adding+the following to the `extra-deps` section of your `stack.yaml` file:++```yaml+extra-deps:+ - validation-selective-0.0.0.0+```
+ src/Validation.hs view
@@ -0,0 +1,1144 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Copyright: (c) 2014 Chris Allen, Edward Kmett+ (c) 2018-2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Lightweight pure data validation based on 'Applicative' and 'Selective' functors.++'Validation' allows to accumulate all errors instead of+short-circuting on the first error so you can display all possible+errors at once.++Common use-cases include:++1. Validating each input of a form with multiple inputs.+2. Performing multiple validations of a single value.++'Validation' provides __modular__ and __composable__ interface which+means that you can implement validations for different pieces of your+data independently, and then combine smaller parts into the validation+of a bigger type. The below table illustrates main ways to combine two+'Validation's:+++---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------++| Typeclass | Operation ○ | 'Failure' e ○ 'Failure' d | 'Success' a ○ 'Success' b | 'Failure' e ○ 'Success' a | 'Success' a ○ 'Failure' e |++===============+=============+===========================+===========================+===========================+===========================++| 'Semigroup' | '<>' | 'Failure' (e '<>' d) | 'Success' (a '<>' b) | 'Failure' e | 'Failure' e |++---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------++| 'Applicative' | '<*>' | 'Failure' (e '<>' d) | 'Success' (a b) | 'Failure' e | 'Failure' e |++---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------++| 'Alternative' | '<|>' | 'Failure' (e '<>' d) | 'Success' a | 'Success' a | 'Success' a |++---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------++| 'Selective' | '<*?' | 'Failure' e | 'Selective' choice | 'Failure' e | 'Selective' choice |++---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------+++In other words, instances of different standard typeclasses provide+various semantics which can be useful in different use-cases:++1. 'Semigroup': accumulate both 'Failure' and 'Success' with '<>'.+2. 'Monoid': 'Success' that stores 'mempty'.+3. 'Functor': change the type inside 'Success'.+4. 'Bifunctor': change both 'Failure' and 'Success'.+5. 'Applicative': apply function to values inside 'Success' and accumulate+ errors inside 'Failure'.+6. 'Alternative': return the first 'Success' or accumulate all errors+ inside 'Failure'.+7. 'Selective': choose which validations to apply based on the value+ inside.+-}++module Validation+ ( -- * Type+ Validation (..)++ -- * How to use+ -- $use++ -- * Interface functions+ , isFailure+ , isSuccess+ , validation+ , failures+ , successes+ , partitionValidations+ , fromFailure+ , fromSuccess++ -- ** 'NonEmpty' combinators+ -- $nonEmptyCombinators+ , failure+ , failureIf+ , failureUnless++ -- ** 'Either' conversion+ -- $either+ , validationToEither+ , eitherToValidation+ ) where++import Control.Applicative (Alternative (..), Applicative (..))+import Control.DeepSeq (NFData, NFData1, NFData2 (..))+import Control.Selective (Selective (..))+import Data.Bifoldable (Bifoldable (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Bitraversable (Bitraversable (..))+import Data.Data (Data)+import Data.Foldable (Foldable (..))+import Data.Kind (Constraint)+import Data.List.NonEmpty (NonEmpty (..))+import GHC.Generics (Generic, Generic1)+import GHC.TypeLits (ErrorMessage (..), TypeError)+++-- $setup+-- >>> import Control.Applicative (liftA3)+-- >>> import Control.Selective (ifS)+-- >>> import Data.Char (isDigit)+-- >>> import Data.Maybe (listToMaybe)+-- >>> import Text.Read (readMaybe)++{- $use++This section contains the typical 'Validation' usage example. Let's say we+have a form with fields where you can input your login information.++>>> :{+data Form = Form+ { formUserName :: !String+ , formPassword :: !String+ }+:}+++This @Form@ data type can represent values of some text fields on the+web page or inside the GUI application. Our goal is to create a value of+the custom @User@ data type from the @Form@ fields.++First, let's define our @User@ type and additional @newtype@s for more+type safety.++>>> :{+newtype UserName = UserName+ { unUserName :: String+ } deriving newtype (Show)+:}++>>> :{+newtype Password = Password+ { unPassword :: String+ } deriving newtype (Show)+:}++>>> :{+data User = User+ { userName :: !UserName+ , userPassword :: !Password+ } deriving stock (Show)+:}++We can easily create a @User@ from the @Form@ in the /unsafe/ way by wrapping+each form field into the corresponding @newtype@:++>>> :{+unsafeUserFromForm :: Form -> User+unsafeUserFromForm Form{..} = User+ { userName = UserName formUserName+ , userPassword = Password formPassword+ }+:}++However, this conversion is unsafe (as name suggests) since @Form@ can+contain /invalid/ data. So, before creating a @User@ we want to check+whether all @Form@ fields satisfy our preconditions. Specifically:++1. User name must not be empty.+2. Password should be at least 8 characters long.+3. Password should contain at least 1 digit.++'Validation' offers __modular__ and __composable__ way of defining and+outputting all validation failures which means:++1. __Modular__: define validation checks for different fields+independently.+2. __Composable__: combine smaller validations easily into a+validation of a bigger type.++Before implementing @Form@ validation, we need to introduce a type for+representing our validation errors. It is a good practice to define+all possible errors as a single sum type, so let's go ahead:++>>> :{+data FormValidationError+ = EmptyName+ | ShortPassword+ | NoDigitPassword+ deriving stock (Show)+:}++With 'Validation' we can define checks for individual fields+independently and compose them later. First, let's start with defining+validation for the name:++>>> :{+validateName :: String -> Validation (NonEmpty FormValidationError) UserName+validateName name = UserName name <$ failureIf (null name) EmptyName+:}++You can notice a few things about this function:++1. All errors are collected in 'NonEmpty', since we want to have+guarantees that in case of errors we have at least one failure.+2. It wraps the result into @UserName@ to tell that validation is+passed.++Let's see how this function works:++>>> validateName "John"+Success "John"+>>> validateName ""+Failure (EmptyName :| [])++Since 'Validation' provides __modular__ interface for defining checks,+we now can define all validation functions for the password+separately:++>>> :{+validateShortPassword :: String -> Validation (NonEmpty FormValidationError) Password+validateShortPassword password = Password password <$+ failureIf (length password < 8) ShortPassword+:}++>>> :{+validatePasswordDigit :: String -> Validation (NonEmpty FormValidationError) Password+validatePasswordDigit password = Password password <$+ failureUnless (any isDigit password) NoDigitPassword+:}++After we've implemented validations for different @Form@ fields, it's+time to combine them together! 'Validation' offers several ways to+compose different validations. These ways are provided via different+instances of common Haskell typeclasses, specifically:++* 'Semigroup'+* 'Alternative'+* 'Applicative'++'Semigroup' allows combining values inside both 'Failure' and+'Success' but this requires both values to implement the 'Semigroup'+instance. This doesn't fit our goal, since @Password@ can't have a+reasonble 'Semigroup' instance.++'Alternative' returns first 'Success' or combines all 'Failure's. We+can notice that 'Alternative' also doesn't work for us here.++In our case we are interested in collecting all possible errors and+returning 'Success' only when all checks are passed. Fortunately,+'Applicative' is exactly what we need here. So we can use the '*>'+operator to compose all checks for password:++>>> :{+validatePassword :: String -> Validation (NonEmpty FormValidationError) Password+validatePassword password =+ validateShortPassword password *> validatePasswordDigit password+:}++Let's see how it works:++>>> validatePassword "abcd"+Failure (ShortPassword :| [NoDigitPassword])+>>> validatePassword "abcd1"+Failure (ShortPassword :| [])+>>> validatePassword "abcd12345"+Success "abcd12345"++After we've implemented validations for all fields, we can compose+them together to produce validation for the whole @User@. As before,+we are going to use the 'Applicative' instance:++>>> :{+validateForm :: Form -> Validation (NonEmpty FormValidationError) User+validateForm Form{..} = User+ <$> validateName formUserName+ <*> validatePassword formPassword+:}++And it works like a charm:++>>> validateForm (Form "" "")+Failure (EmptyName :| [ShortPassword,NoDigitPassword])+>>> validateForm (Form "John" "abc")+Failure (ShortPassword :| [NoDigitPassword])+>>> validateForm (Form "Jonh" "qwertypassword")+Failure (NoDigitPassword :| [])+>>> validateForm (Form "Jonh" "qwertypassword123")+Success (User {userName = "Jonh", userPassword = "qwertypassword123"})+-}++{- | 'Validation' is a polymorphic sum type for storing either all+validation failures or validation success. Unlike 'Either', which+returns only the first error, 'Validation' accumulates all errors+using the 'Semigroup' typeclass.++Usually type variables in @'Validation' e a@ are used as follows:++* @e@: is a list or set of failure messages or values of some error data type.+* @a@: is some domain type denoting successful validation result.++Some typical use-cases:++* @'Validation' ['String'] User@++ * Either list of 'String' error messages or a validated value of a+ custom @User@ type.++* @'Validation' ('NonEmpty' UserValidationError) User@++ * Similar to previous example, but list of failures guaranteed to+ be non-empty in case of validation failure, and it stores values+ of some custom error type.+-}+data Validation e a+ = Failure e+ -- ^ Validation failure. The @e@ type is supposed to implement the 'Semigroup' instance.+ | Success a+ -- ^ Successful validation result of type @a@.+ deriving stock (Eq, Ord, Show, Generic, Generic1, Data)+ deriving anyclass (NFData, NFData1)++{- | Allows changing the value inside 'Success' with a given function.++__Examples__++>>> fmap (+1) (Success 9)+Success 10+>>> fmap (+1) (Failure ["wrong"])+Failure ["wrong"]+-}+instance Functor (Validation e) where+ fmap :: (a -> b) -> Validation e a -> Validation e b+ fmap _ (Failure e) = Failure e+ fmap f (Success a) = Success (f a)+ {-# INLINE fmap #-}++ (<$) :: a -> Validation e b -> Validation e a+ x <$ Success _ = Success x+ _ <$ Failure e = Failure e+ {-# INLINE (<$) #-}++{- | 'Semigroup' allows merging multiple 'Validation's into single one+by combining values inside both 'Failure' and 'Success'. The '<>'+operator merges two 'Validation's following the below rules:++1. If both values are 'Failure's, returns a new 'Failure' with+accumulated errors.+2. If both values are 'Success'ful, returns a new 'Success' with+combined success using 'Semigroup' for values inside 'Success'.+3. If one value is 'Failure' and another one is 'Success', then+'Failure' is returned.++__Examples__++>>> success1 = Success [9] :: Validation [String] [Int]+>>> success2 = Success [15] :: Validation [String] [Int]+>>> failure1 = Failure ["WRONG"] :: Validation [String] [Int]+>>> failure2 = Failure ["FAIL"] :: Validation [String] [Int]++>>> success1 <> success2+Success [9,15]+>>> failure1 <> failure2+Failure ["WRONG","FAIL"]+>>> success1 <> failure1+Failure ["WRONG"]+>>> failure2 <> success1 <> success2 <> failure1+Failure ["FAIL","WRONG"]+-}+instance (Semigroup e, Semigroup a) => Semigroup (Validation e a) where+ (<>) :: Validation e a -> Validation e a -> Validation e a+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}++{- | @'mempty' :: 'Validation' e a@ is @Success@ which stores+@'mempty' :: a@ to be consistent with the 'Semigroup' instance.++__Examples__++>>> mempty :: Validation String [Bool]+Success []+-}+instance (Semigroup e, Semigroup a, Monoid a) => Monoid (Validation e a) where+ mempty :: Validation e a+ mempty = Success mempty+ {-# INLINE mempty #-}++ mappend :: Validation e a -> Validation e a -> Validation e a+ mappend = (<>)+ {-# INLINE mappend #-}++{- | This instance if the most important instance for the 'Validation' data+type. It's responsible for the many implementations. And it allows to accumulate+errors while performing validation or combining the results in the applicative+style.++__Examples__++>>> success1 = Success 9 :: Validation [String] Int+>>> success2 = Success 15 :: Validation [String] Int+>>> successF = Success (* 2) :: Validation [String] (Int -> Int)+>>> failure1 = Failure ["WRONG"] :: Validation [String] Int+>>> failure2 = Failure ["FAIL"] :: Validation [String] Int++>>> successF <*> success1+Success 18+>>> successF <*> failure1+Failure ["WRONG"]+>>> (+) <$> success1 <*> success2+Success 24+>>> (+) <$> failure1 <*> failure2+Failure ["WRONG","FAIL"]+>>> liftA2 (+) success1 failure1+Failure ["WRONG"]+>>> liftA3 (,,) failure1 success1 failure2+Failure ["WRONG","FAIL"]++Implementations of all functions are lazy and they correctly work if some+arguments are not fully evaluated.++>>> failure1 *> failure2+Failure ["WRONG","FAIL"]+>>> isFailure $ failure1 *> failure2+True+>>> epicFail = error "Impossible validation" :: Validation [String] Int+>>> isFailure $ failure1 *> epicFail+True+-}+instance Semigroup e => Applicative (Validation e) where+ pure :: a -> Validation e a+ pure = Success+ {-# INLINE pure #-}++ (<*>) :: Validation e (a -> b) -> Validation e a -> Validation e b+ Failure e1 <*> b = Failure $ case b of+ Failure e2 -> e1 <> e2+ Success _ -> e1+ Success _ <*> Failure e = Failure e+ Success f <*> Success a = Success (f a)+ {-# INLINE (<*>) #-}++ (*>) :: Validation e a -> Validation e b -> Validation e b+ Failure e1 *> b = Failure $ case b of+ Failure e2 -> e1 <> e2+ Success _ -> e1+ Success _ *> Failure e = Failure e+ Success _ *> Success b = Success b+ {-# INLINE (*>) #-}++ (<*) :: Validation e a -> Validation e b -> Validation e a+ Failure e1 <* b = Failure $ case b of+ Failure e2 -> e1 <> e2+ Success _ -> e1+ Success _ <* Failure e = Failure e+ Success a <* Success _ = Success a+ {-# INLINE (<*) #-}++ liftA2 :: (a -> b -> c) -> Validation e a -> Validation e b -> Validation e c+ liftA2 _ (Failure e1) b = Failure $ case b of+ Failure e2 -> e1 <> e2+ Success _ -> e1+ liftA2 _ (Success _) (Failure e) = Failure e+ liftA2 f (Success a) (Success b) = Success (f a b)+ {-# INLINE liftA2 #-}++{- | 'Selective' functors from the [selective](https://hackage.haskell.org/package/selective)+package. This instance allows choosing which validations to apply+based on value inside. 'Validation' can't have a lawful 'Monad'+instance but it's highly desirable to have the monadic behavior in cases+when you want future checks depend on previous values. 'Selective'+allows to circumvent this limitation by providing the desired+behavior.++==== __Examples__++To understand better, how 'Selective' can be helpful, let's consider a+typical usage example with validating passwords.++>>> :{+newtype Password = Password+ { unPassword :: String+ } deriving stock (Show)+:}++When user enters a password in some form, we want to check the+following conditions:++1. Password must not be empty.+2. Password must contain at least 8 characters.+3. Password must contain at least 1 digit.++As in the previous usage example with form validation, let's introduce+a custom data type to represent all possible errors.++>>> :{+data PasswordValidationError+ = EmptyPassword+ | ShortPassword+ | NoDigitPassword+ deriving stock (Show)+:}++And, again, we can implement independent functions to validate all these cases:++>>> type PasswordValidation = Validation (NonEmpty PasswordValidationError) Password++>>> :{+validateEmptyPassword :: String -> PasswordValidation+validateEmptyPassword password = Password password <$+ failureIf (null password) EmptyPassword+:}++>>> :{+validateShortPassword :: String -> PasswordValidation+validateShortPassword password = Password password <$+ failureIf (length password < 8) ShortPassword+:}++>>> :{+validatePasswordDigit :: String -> PasswordValidation+validatePasswordDigit password = Password password <$+ failureUnless (any isDigit password) NoDigitPassword+:}++And we can easily compose all these checks into single validation for+@Password@ using 'Applicative' instance:++>>> :{+validatePassword :: String -> PasswordValidation+validatePassword password =+ validateEmptyPassword password+ *> validateShortPassword password+ *> validatePasswordDigit password+:}++However, if we try using this function, we can notice a problem+immediately:++>>> validatePassword ""+Failure (EmptyPassword :| [ShortPassword,NoDigitPassword])++Due to the nature of the 'Applicative' instance for 'Validation', we+run all checks and combine all possible errors. But you can notice+that if password is empty, it doesn't make sense to run other+validations. The fact that the password is empty implies that password+is shorter than 8 characters.++You may say that check for empty password is redundant because empty+password is a special case of a short password. However, when using+'Validation', we want to display readable and friendly errors to+users, so they know how to fix errors and can act correspondingly.++This behaviour could be achieved easily if 'Validation' had the+'Monad' instance. But it can't have a lawful 'Monad'+instance. Fortunately, the 'Selective' instance for 'Validation' can+help with our problem. But to solve it, we need to write our password+validation in a slightly different way.++First, we need to write a function that checks whether the password is+empty:++>>> :{+checkEmptyPassword :: String -> Validation e Bool+checkEmptyPassword = Success . null+:}++Now we can use the @ifS@ function from the @selective@ package to+branch on the result of @checkEmptyPassword@:++>>> :{+validatePassword :: String -> PasswordValidation+validatePassword password = ifS+ (checkEmptyPassword password)+ (failure EmptyPassword)+ (validateShortPassword password *> validatePasswordDigit password)+:}++With this implementation we achieved our desired behavior:++>>> validatePassword ""+Failure (EmptyPassword :| [])+>>> validatePassword "abc"+Failure (ShortPassword :| [NoDigitPassword])+>>> validatePassword "abc123"+Failure (ShortPassword :| [])+>>> validatePassword "security567"+Success (Password {unPassword = "security567"})+-}+instance Semigroup e => Selective (Validation e) where+ select :: Validation e (Either a b) -> Validation e (a -> b) -> Validation e b+ select (Failure e) _ = Failure e -- Skip effect after failed conditions+ select (Success eab) f = case eab of+ Left a -> ($ a) <$> f -- Apply second effect+ Right b -> Success b -- Skip second effect+ {-# INLINE select #-}++{- | This instance implements the behaviour when the first 'Success'+is returned. Otherwise all 'Failure's are combined.++__Examples__++>>> success1 = Success [9] :: Validation [String] [Int]+>>> success2 = Success [15] :: Validation [String] [Int]+>>> failure1 = Failure ["WRONG"] :: Validation [String] [Int]+>>> failure2 = Failure ["FAIL"] :: Validation [String] [Int]++>>> success1 <|> success2+Success [9]+>>> failure1 <|> failure2+Failure ["WRONG","FAIL"]+>>> failure2 <|> success2+Success [15]+-}+instance (Semigroup e, Monoid e) => Alternative (Validation e) where+ empty :: Validation e a+ empty = Failure mempty+ {-# INLINE empty #-}++ (<|>) :: Validation e a -> Validation e a -> Validation e a+ s@Success{} <|> _ = s+ _ <|> s@Success{} = s+ Failure e <|> Failure e' = Failure (e <> e')+ {-# INLINE (<|>) #-}++{- | 'Foldable' for 'Validation' allows folding values inside 'Success'.++__Examples__++>>> fold (Success [16])+[16]+>>> fold (Failure "WRONG!" :: Validation String [Int])+[]+-}+instance Foldable (Validation e) where+ fold :: Monoid m => Validation e m -> m+ fold = \case+ Failure _ -> mempty+ Success a -> a+ {-# INLINE fold #-}++ foldMap :: Monoid m => (a -> m) -> Validation e a -> m+ foldMap f = \case+ Failure _ -> mempty+ Success a -> f a+ {-# INLINE foldMap #-}++ foldr :: (a -> b -> b) -> b -> Validation e a -> b+ foldr f x = \case+ Failure _ -> x+ Success a -> f a x+ {-# INLINE foldr #-}++ foldr' :: (a -> b -> b) -> b -> Validation e a -> b+ foldr' = foldr+ {-# INLINE foldr' #-}++ foldl :: (b -> a -> b) -> b -> Validation e a -> b+ foldl f x = \case+ Failure _ -> x+ Success a -> f x a+ {-# INLINE foldl #-}++ foldl' :: (b -> a -> b) -> b -> Validation e a -> b+ foldl' = foldl+ {-# INLINE foldl' #-}++ toList :: Validation e a -> [a]+ toList = \case+ Failure _ -> []+ Success a -> [a]+ {-# INLINE toList #-}++ null :: Validation e a -> Bool+ null = \case+ Failure _ -> True+ Success _ -> False+ {-# INLINE null #-}++ length :: Validation e a -> Int+ length = \case+ Failure _ -> 0+ Success _ -> 1+ {-# INLINE length #-}++ elem :: Eq a => a -> Validation e a -> Bool+ elem x = \case+ Failure _ -> False+ Success a -> x == a+ {-# INLINE elem #-}++ sum :: Num a => Validation e a -> a+ sum = \case+ Failure _ -> 0+ Success a -> a+ {-# INLINE sum #-}++ product :: Num a => Validation e a -> a+ product = \case+ Failure _ -> 1+ Success a -> a+ {-# INLINE product #-}++ -- not-implemented because they are partial, so we're using the+ -- default implementations+ --+ -- foldr1 :: (a -> a -> a) -> Validation e a -> a+ -- foldl1 :: (a -> a -> a) -> Validation e a -> a+ -- maximum :: Ord a => Validation e a -> a+ -- minimum :: Ord a => Validation e a -> a++{- | Traverse values inside 'Success' with some effectful computation.++__Examples__++>>> parseInt = readMaybe :: String -> Maybe Int+>>> traverse parseInt (Success "42")+Just (Success 42)+>>> traverse parseInt (Success "int")+Nothing+>>> traverse parseInt (Failure ["42"])+Just (Failure ["42"])+-}+instance Traversable (Validation e) where+ traverse :: Applicative f => (a -> f b) -> Validation e a -> f (Validation e b)+ traverse f (Success a) = Success <$> f a+ traverse _ (Failure e) = pure (Failure e)+ {-# INLINE traverse #-}++ sequenceA :: Applicative f => Validation e (f a) -> f (Validation e a)+ sequenceA = \case+ Failure e -> pure (Failure e)+ Success f -> Success <$> f+ {-# INLINE sequenceA #-}++{- | Similar to 'Functor' but allows mapping of values inside both+'Failure' and 'Success'.++__Examples__++>>> bimap length show (Success 50)+Success "50"+>>> bimap length show (Failure ["15", "9"])+Failure 2+-}+instance Bifunctor Validation where+ bimap :: (e -> d) -> (a -> b) -> Validation e a -> Validation d b+ bimap f _ (Failure e) = Failure (f e)+ bimap _ g (Success a) = Success (g a)+ {-# INLINE bimap #-}++ first :: (e -> d) -> Validation e a -> Validation d a+ first f (Failure e) = Failure (f e)+ first _ (Success a) = Success a+ {-# INLINE first #-}++ second :: (a -> b) -> Validation e a -> Validation e b+ second _ (Failure e) = Failure e+ second g (Success a) = Success (g a)+ {-# INLINE second #-}++{- | Similar to 'Foldable' but allows folding both 'Failure' and+'Success' to the same monoidal value according to given functions.++__Examples__++>>> one x = [x]+>>> bifoldMap id (one . show) (Success 15)+["15"]+>>> bifoldMap id (one . show) (Failure ["Wrong", "Fail"])+["Wrong","Fail"]+-}+instance Bifoldable Validation where+-- bifoldMap :: (e -> m) -> (a -> m) -> Validation e a -> m+ bifoldMap f _ (Failure e) = f e+ bifoldMap _ g (Success a) = g a+ {-# INLINE bifoldMap #-}++{- | Similar to 'Traversable' but traverses both 'Failure' and+'Success' with given effectful computations.++__Examples__++>>> parseInt = readMaybe :: String -> Maybe Int+>>> bitraverse listToMaybe parseInt (Success "42")+Just (Success 42)+>>> bitraverse listToMaybe parseInt (Success "int")+Nothing+>>> bitraverse listToMaybe parseInt (Failure [15])+Just (Failure 15)+>>> bitraverse listToMaybe parseInt (Failure [])+Nothing+-}+instance Bitraversable Validation where+ bitraverse+ :: Applicative f+ => (e -> f d)+ -> (a -> f b)+ -> Validation e a+ -> f (Validation d b)+ bitraverse f _ (Failure e) = Failure <$> f e+ bitraverse _ g (Success a) = Success <$> g a+ {-# INLINE bitraverse #-}++instance NFData2 Validation where+ liftRnf2 :: (e -> ()) -> (a -> ()) -> Validation e a -> ()+ liftRnf2 f _s (Failure x) = f x+ liftRnf2 _f s (Success y) = s y++----------------------------------------------------------------------------+-- Custom errors+----------------------------------------------------------------------------++{- | ⚠️__CAUTION__⚠️ This instance is for custom error display only.++It's not possible to implement lawful 'Monad' instance for 'Validation'.++In case it is used by mistake, the user will see the following:++>>> Success 42 >>= \n -> if even n then Success n else Failure ["Not even"]+...+... Type 'Validation' doesn't have lawful 'Monad' instance+ which means that you can't use 'Monad' methods with 'Validation'.+...+-}+instance (NoValidationMonadError, Semigroup e) => Monad (Validation e) where+ return = error "Unreachable Validation instance of Monad"+ (>>=) = error "Unreachable Validation instance of Monad"++-- | Helper type family to produce error messages+type family NoValidationMonadError :: Constraint where+ NoValidationMonadError = TypeError+ ( 'Text "Type 'Validation' doesn't have lawful 'Monad' instance"+ ':$$: 'Text "which means that you can't use 'Monad' methods with 'Validation'."+ )++----------------------------------------------------------------------------+-- Either+----------------------------------------------------------------------------++{- $either+'Validation' is usually compared to the 'Either' data type due to the similarity+in structure, nature and use case. Here is a quick table you can relate to, in+order to see the main properties and differences between these two data types:+++------------------------+---------------------------+---------------------------++| | 'Either' | 'Validation' |++========================+===========================+===========================++| Error result | 'Left' | 'Failure' |++------------------------+---------------------------+---------------------------++| Successful result | 'Right' | 'Success' |++------------------------+---------------------------+---------------------------++| 'Applicative' instance | Stops on the first 'Left' | Aggregates all 'Failure's |++------------------------+---------------------------+---------------------------++| 'Monad' instance | Lawful instance | __Cannot__ exist |++------------------------+---------------------------+---------------------------+++== Comparison in example++For the sake of better illustration of the difference between 'Either' and+'Validation', let's go through the example of how parsing is done with the usage of+these types.++Our goal is to parse two given 'String's and return their sum in case if both of+them are valid 'Int's. If any of the inputs is failing to be parsed we should+return the @ParseError@ which we are introducing right now:++>>> :{+newtype ParseError = ParseError+ { nonParsedString :: String+ } deriving stock (Show)+:}++Let's first implement the parsing of single input in the 'Either' context:++>>> :{+parseEither :: String -> Either ParseError Int+parseEither input = case readMaybe @Int input of+ Just x -> Right x+ Nothing -> Left $ ParseError input+:}++And the final function for 'Either' looks like this:++>>> :{+parseSumEither :: String -> String -> Either ParseError Int+parseSumEither str1 str2 = do+ let x = parseEither str1+ let y = parseEither str2+ liftA2 (+) x y+:}++Let's now test it in action.++>>> parseSumEither "1" "2"+Right 3+>>> parseSumEither "NaN" "42"+Left (ParseError {nonParsedString = "NaN"})+>>> parseSumEither "15" "Infinity"+Left (ParseError {nonParsedString = "Infinity"})+>>> parseSumEither "NaN" "infinity"+Left (ParseError {nonParsedString = "NaN"})++__Note__ how in the case of both failed parsing we got only the first @NaN@.++To finish our comparison, let's implement the same functionality using+'Validation' properties.++>>> :{+parseValidation :: String -> Validation (NonEmpty ParseError) Int+parseValidation input = case readMaybe @Int input of+ Just x -> Success x+ Nothing -> failure $ ParseError input+:}++>>> :{+parseSumValidation :: String -> String -> Validation (NonEmpty ParseError) Int+parseSumValidation str1 str2 = do+ let x = parseValidation str1+ let y = parseValidation str2+ liftA2 (+) x y+:}++It looks almost completely identical except for the resulting type —+@'Validation' ('NonEmpty' ParseError) 'Int'@. But let's see if they behave the+same way:++>>> parseSumValidation "1" "2"+Success 3+>>> parseSumValidation "NaN" "42"+Failure (ParseError {nonParsedString = "NaN"} :| [])+>>> parseSumValidation "15" "infinity"+Failure (ParseError {nonParsedString = "infinity"} :| [])+>>> parseSumValidation "NaN" "infinity"+Failure (ParseError {nonParsedString = "NaN"} :| [ParseError {nonParsedString = "infinity"}])++As expected, with 'Validation' we got __all__ parse 'Failure's we received on+the way.++== Combinators++We are providing several functions for better integration with the 'Either'+related code in this section.+-}++{- | Transform a 'Validation' into an 'Either'.++>>> validationToEither (Success "whoop")+Right "whoop"++>>> validationToEither (Failure "nahh")+Left "nahh"+-}+validationToEither :: Validation e a -> Either e a+validationToEither = \case+ Failure e -> Left e+ Success a -> Right a+{-# INLINE validationToEither #-}++{- | Transform an 'Either' into a 'Validation'.++>>> eitherToValidation (Right "whoop")+Success "whoop"++>>> eitherToValidation (Left "nahh")+Failure "nahh"+-}+eitherToValidation :: Either e a -> Validation e a+eitherToValidation = \case+ Left e -> Failure e+ Right a -> Success a+{-# INLINE eitherToValidation #-}++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++{- | Predicate on if the given 'Validation' is 'Failure'.++>>> isFailure (Failure 'e')+True+>>> isFailure (Success 'a')+False+-}+isFailure :: Validation e a -> Bool+isFailure = \case+ Failure _ -> True+ Success _ -> False++{- | Predicate on if the given 'Validation' is 'Success'.++>>> isSuccess (Success 'a')+True+>>> isSuccess (Failure 'e')+False+-}+isSuccess :: Validation e a -> Bool+isSuccess = \case+ Success _ -> True+ Failure _ -> False++{- | Transforms the value of the given 'Validation' into @x@ using provided+functions that can transform 'Failure' and 'Success' value into the resulting+type respectively.++>>> let myValidation = validation (<> " world!") (show . (* 10))+>>> myValidation (Success 100)+"1000"+>>> myValidation (Failure "Hello")+"Hello world!"+-}+validation :: (e -> x) -> (a -> x) -> Validation e a -> x+validation fe fa = \case+ Success a -> fa a+ Failure e -> fe e++{- | Filters out all 'Failure' values into the new list of @e@s from the given+list of 'Validation's.++Note that the order is preserved.++>>> failures [Failure "Hello", Success 1, Failure "world", Success 2, Failure "!" ]+["Hello","world","!"]+-}+failures :: [Validation e a] -> [e]+failures v = [e | Failure e <- v]+{-# INLINE failures #-}++{- | Filters out all 'Success' values into the new list of @a@s from the given+list of 'Validation's.++Note that the order is preserved.++>>> successes [Failure "Hello", Success 1, Failure "world", Success 2, Failure "!" ]+[1,2]+-}+successes :: [Validation e a] -> [a]+successes v = [a | Success a <- v]+{-# INLINE successes #-}++{- | Redistributes the given list of 'Validation's into two lists of @e@s and+@e@s, where the first list contains all values of 'Failure's and the second+one — 'Success'es correspondingly.++Note that the order is preserved.++>>> partitionValidations [Failure "Hello", Success 1, Failure "world", Success 2, Failure "!" ]+(["Hello","world","!"],[1,2])+-}+partitionValidations :: [Validation e a] -> ([e], [a])+partitionValidations = go+ where+ go :: [Validation e a] -> ([e], [a])+ go [] = ([], [])+ go (Failure e:rest) = first (e:) $ go rest+ go (Success a:rest) = second (a:) $ go rest++{- | Returns the contents of a 'Failure'-value or a default value otherwise.++>>> fromFailure "default" (Failure "failure")+"failure"+>>> fromFailure "default" (Success 1)+"default"+-}+fromFailure :: e -> Validation e a -> e+fromFailure _ (Failure e) = e+fromFailure e _ = e++{- | Returns the contents of a 'Success'-value or a default value otherwise.++>>> fromSuccess 42 (Success 1)+1+>>> fromSuccess 42 (Failure "failure")+42+-}+fromSuccess :: a -> Validation e a -> a+fromSuccess _ (Success a) = a+fromSuccess a _ = a++----------------------------------------------------------------------------+-- NonEmpty Combinators+----------------------------------------------------------------------------++{- $nonEmptyCombinators++When using 'Validation', we often work with the 'NonEmpty' list of errors, and+those lists will be concatenated later.++The following functions aim to help with writing more concise code.++For example, instead of (perfectly fine) code like:++>>> :{+validateNameVerbose :: String -> Validation (NonEmpty String) String+validateNameVerbose name+ | null name = Failure ("Empty Name" :| [])+ | otherwise = Success name+:}++one can write simply:++>>> :{+validateNameSimple :: String -> Validation (NonEmpty String) String+validateNameSimple name = name <$ failureIf (null name) "Empty Name"+:}++-}++{- | Create a 'Failure' of 'NonEmpty' list with a single given error.++>>> failure "I am a failure"+Failure ("I am a failure" :| [])+-}+failure :: e -> Validation (NonEmpty e) a+failure e = Failure (e :| [])+{-# INLINE failure #-}++{- | Returns a 'Failure' in case of the given predicate is 'True'.+Returns @'Success' '()'@ otherwise.++>>> let shouldFail = (==) "I am a failure"+>>> failureIf (shouldFail "I am a failure") "I told you so"+Failure ("I told you so" :| [])+>>> failureIf (shouldFail "I am NOT a failure") "okay"+Success ()+-}+failureIf :: Bool -> e -> Validation (NonEmpty e) ()+failureIf p e+ | p = failure e+ | otherwise = Success ()+{-# INLINE failureIf #-}++{- | Returns a 'Failure' unless the given predicate is 'True'.+Returns @'Success' '()'@ in case of the predicate is satisfied.++Similar to 'failureIf' with the reversed predicate.++@+'failureUnless' p ≡ 'failureIf' (not p)+@++>>> let shouldFail = (==) "I am a failure"+>>> failureUnless (shouldFail "I am a failure") "doesn't matter"+Success ()+>>> failureUnless (shouldFail "I am NOT a failure") "I told you so"+Failure ("I told you so" :| [])+-}+failureUnless :: Bool -> e -> Validation (NonEmpty e) ()+failureUnless p e+ | p = Success ()+ | otherwise = failure e+{-# INLINE failureUnless #-}
+ test/Doctest.hs view
@@ -0,0 +1,26 @@+{-+Copyright: (c) 2018-2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++DocTest's run function to keep docs up to date.+-}++module Main (main) where++import Test.DocTest (doctest)+++main :: IO ()+main = doctest+ $ "-XDeriveAnyClass"+ : "-XDeriveGeneric"+ : "-XDerivingStrategies"+ : "-XGeneralizedNewtypeDeriving"+ : "-XInstanceSigs"+ : "-XLambdaCase"+ : "-XOverloadedStrings"+ : "-XRecordWildCards"+ : "-XScopedTypeVariables"+ : "-XTypeApplications"+ : [ "src/Validation.hs" ]
+ test/Spec.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import Test.Hspec (hspec)++import Test.Laws (validationLawsSpec)+import Test.Properties (propertiesSpec)+++main :: IO ()+main = hspec $ do+ validationLawsSpec+ propertiesSpec
+ test/Test/Gen.hs view
@@ -0,0 +1,81 @@+{- | Generators for test data types.+-}++module Test.Gen+ ( Property+ , genValidation+ , genValidationList+ , genFunction+ , genFunction2+ , genInt+ , genSmallInt+ , genSmallText+ , genSmallList+ , genEither+ ) where++import Data.Text (Text)+import Hedgehog (Gen, MonadGen, PropertyT)+import Validation (Validation (..))++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++-- | Helper alias for tests.+type Property = PropertyT IO ()++-- | Generate a simple unary function from the list.+genFunction :: Gen (Int -> Int)+genFunction = genInt >>= \n -> Gen.element+ [ id+ , (+ n)+ , (* n)+ , const n+ , (n -)+ , subtract n+ ]++-- | Generate a simple binary function from the list.+genFunction2 :: Gen (Int -> Int -> Int)+genFunction2 = Gen.element+ [ const+ , (+)+ , (*)+ , (-)+ , subtract+ ]++-- | Generate an 'Int'.+genInt :: Gen Int+genInt = Gen.enumBounded++-- | Generate a positive 'Int' within the range of @1-6@.+genSmallInt :: Gen Int+genSmallInt = Gen.int (Range.linear 1 6)++-- | Generate a 'Text' of length @0-10@.+genSmallText :: Gen Text+genSmallText = Gen.text (Range.linear 0 10) Gen.unicode++-- | Generate a small list of the given generated elements.+genSmallList :: Gen a -> Gen [a]+genSmallList = Gen.list (Range.linear 0 6)++-- | Generate a 'Validation'.+genValidation :: Gen a -> Gen (Validation [Text] a)+genValidation gen = Gen.choice+ [ Success <$> gen+ , Failure <$> genSmallList genSmallText+ ]++-- | Generate 'Either' with more frequent 'Right's.+genEither :: MonadGen m => m e -> m a -> m (Either e a)+genEither genE genA = Gen.sized $ \n -> Gen.frequency+ [ (2, Left <$> genE)+ , (1 + fromIntegral n, Right <$> genA)+ ]++-- | Generate a list of 'Validation's.+genValidationList :: Gen a -> Gen [Validation [Text] a]+genValidationList = Gen.list (Range.linear 0 200) . genValidation
+ test/Test/Laws.hs view
@@ -0,0 +1,270 @@+{- HLINT ignore "Alternative law, right identity" -}+{- HLINT ignore "Alternative law, left identity" -}+{- HLINT ignore "Monoid law, right identity" -}+{- HLINT ignore "Monoid law, left identity" -}+{- HLINT ignore "Functor law" -}+{- HLINT ignore "Use <$>" -}+{- HLINT ignore "Use mconcat" -}+{- HLINT ignore "Redundant id" -}+{- HLINT ignore "Reduce duplication" -}++{-+Copyright: (c) 2018-2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>+-}++module Test.Laws+ ( validationLawsSpec+ ) where++import Control.Applicative (Alternative (empty, (<|>)), Applicative (liftA2))+import Control.Selective ((<*?))+import Data.Bifunctor (bimap)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Semigroup (sconcat, stimes)+import Data.Text (Text)+import Hedgehog (Gen, forAll, forAllWith, (===))+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Hedgehog (hedgehog)+import Validation (Validation (..))++import Test.Gen (Property, genEither, genFunction, genFunction2, genInt, genSmallInt, genSmallList,+ genSmallText, genValidation)+++validationLawsSpec :: Spec+validationLawsSpec = describe "Validation Property Tests" $ do+ describe "Semigroup instance for Validation" $ do+ it "Associativity: a <> (b <> c) ≡ (a <> b) <> c"+ semigroupAssociativity+ it "Concatenation: sconcat ≡ foldr1 (<>)"+ semigroupConcatenation+ it "Times: stimes n a ≡ foldr1 (<>) (replicate n a)"+ semigroupTimes+ describe "Monoid instance for Validation" $ do+ it "Right Identity: x <> mempty ≡ x" monoidRightIdentity+ it "Left Identity: mempty <> x ≡ x" monoidLeftIdentity+ it "Associativity: mappend a (mappend b c) ≡ mappend (mappend a b) c"+ monoidAssociativity+ it "Concatenation: mconcat ≡ foldr mappend mempty"+ monoidConcatenation+ describe "Functor instance for Validation" $ do+ it "Identity: fmap id ≡ id"+ functorIdentity+ it "Composition: map f . fmap g ≡ fmap (f . g)"+ functorComposition+ it "Const: fmap (const x) ≡ x <$"+ functorConst+ describe "Applicative instance for Validation" $ do+ it "Identity: pure id <*> x ≡ x"+ applicativeIdentity+ it "Composition: pure (.) <*> f <*> g <*> x ≡ f <*> (g <*> x)"+ applicativeComposition+ it "Homomorphism: pure f <*> pure x ≡ pure (f x)"+ applicativeHomomorphism+ it "Interchange: f <*> pure x ≡ pure ($ x) <*> f"+ applicativeInterchange+ it "Apply Right: u *> v ≡ (id <$ u) <*> v" applicativeApplyRight+ it "Apply Left: u <* v ≡ liftA2 const u v" applicativeApplyLeft+ it "(<*>) via liftA2: (<*>) ≡ liftA2 id"+ applicativeApViaLiftA2+ it "liftA2 via (<*>): liftA2 f x y ≡ f <$> x <*> y"+ applicativeLiftA2ViaAp++ describe "Alternative instance for Validation" $ do+ it "Associativity: a <|> (b <|> c) ≡ (a <|> b) <|> c"+ alternativeAssociativity+ it "Right Identity: x <|> empty ≡ x" alternativeRightIdentity+ it "Left Identity: empty <|> x ≡ x" alternativeLeftIdentity+ describe "Selective instance for Validation" $ do+ it "Identity: x <*? pure id ≡ either id id <$> x"+ selectiveIdentity+ it "Distributivity: pure x <*? (y *> z) ≡ (pure x <*? y) *> (pure x <*? z)"+ selectiveDistributivity+ it "Associativity: x <*? (y <*? z) ≡ (f <$> x) <*? (g <$> y) <*? (h <$> z)"+ selectiveAssociativity++----------------------------------------------------------------------------+-- Semigroup instance properties+----------------------------------------------------------------------------++semigroupAssociativity :: Property+semigroupAssociativity = checkAssotiativityFor (genValidation genSmallText) (<>)++semigroupConcatenation :: Property+semigroupConcatenation = do+ let gen = genValidation genSmallText+ a <- forAll gen+ as <- forAll $ genSmallList gen+ let ne = a :| as+ sconcat ne === foldr1 (<>) ne++semigroupTimes :: Property+semigroupTimes = do+ a <- forAll $ genValidation genSmallText+ n <- forAll genSmallInt+ stimes n a === foldr1 (<>) (replicate n a)++----------------------------------------------------------------------------+-- Monoid instance properties+----------------------------------------------------------------------------++monoidRightIdentity :: Property+monoidRightIdentity = hedgehog $ do+ x <- forAll $ genValidation genSmallText+ x <> mempty === x++monoidLeftIdentity :: Property+monoidLeftIdentity = hedgehog $ do+ x <- forAll $ genValidation genSmallText+ mempty <> x === x++monoidAssociativity :: Property+monoidAssociativity = checkAssotiativityFor (genValidation genSmallText) mappend++monoidConcatenation :: Property+monoidConcatenation = hedgehog $ do+ as <- forAll $ genSmallList $ genValidation genSmallText+ mconcat as === foldr mappend mempty as++----------------------------------------------------------------------------+-- Functor instance laws+----------------------------------------------------------------------------++functorIdentity :: Property+functorIdentity = hedgehog $ do+ a <- forAll $ genValidation genSmallText+ fmap id a === id a++functorComposition :: Property+functorComposition = hedgehog $ do+ a <- forAll $ genValidation genInt+ f <- forAllWith (const "f") genFunction+ g <- forAllWith (const "g") genFunction+ fmap f (fmap g a) === fmap (f . g) a++functorConst :: Property+functorConst = hedgehog $ do+ a <- forAll $ genValidation genSmallText+ let x = 'X'+ fmap (const x) a === (x <$ a)++----------------------------------------------------------------------------+-- Applicative instance properties+----------------------------------------------------------------------------++applicativeIdentity :: Property+applicativeIdentity = hedgehog $ do+ vx <- forAll $ genValidation genSmallText+ (pure id <*> vx) === vx++applicativeComposition :: Property+applicativeComposition = hedgehog $ do+ vf <- forAllWith (const "f") $ genValidation genFunction+ vg <- forAllWith (const "g") $ genValidation genFunction+ vx <- forAll $ genValidation genInt+ (pure (.) <*> vf <*> vg <*> vx) === (vf <*> (vg <*> vx))++applicativeHomomorphism :: Property+applicativeHomomorphism = hedgehog $ do+ f <- forAllWith (const "f") genFunction+ x <- forAll genInt+ (pure f <*> pure x) === pure @(Validation [Text]) (f x)++applicativeInterchange :: Property+applicativeInterchange = hedgehog $ do+ vf <- forAllWith (const "f") $ genValidation genFunction+ x <- forAll genInt+ (vf <*> pure x) === (pure ($ x) <*> vf)++applicativeApplyRight :: Property+applicativeApplyRight = hedgehog $ do+ let genVal = genValidation genInt+ vy <- forAll genVal+ vx <- forAll genVal+ (vy *> vx) === ((id <$ vy) <*> vx)++applicativeApplyLeft :: Property+applicativeApplyLeft = hedgehog $ do+ let genVal = genValidation genInt+ vy <- forAll genVal+ vx <- forAll genVal+ (vy <* vx) === liftA2 const vy vx++applicativeApViaLiftA2 :: Property+applicativeApViaLiftA2 = hedgehog $ do+ vf <- forAllWith (const "f") $ genValidation genFunction+ vx <- forAll $ genValidation genInt+ (vf <*> vx) === liftA2 id vf vx++applicativeLiftA2ViaAp :: Property+applicativeLiftA2ViaAp = hedgehog $ do+ f <- forAllWith (const "f") genFunction2+ vx <- forAll $ genValidation genInt+ vy <- forAll $ genValidation genInt+ liftA2 f vx vy === (f <$> vx <*> vy)++----------------------------------------------------------------------------+-- Alternative instance properties+----------------------------------------------------------------------------++alternativeAssociativity :: Property+alternativeAssociativity = checkAssotiativityFor (genValidation genSmallText) (<|>)++alternativeRightIdentity :: Property+alternativeRightIdentity = hedgehog $ do+ x <- forAll $ genValidation genSmallText+ (x <|> empty) === x++alternativeLeftIdentity :: Property+alternativeLeftIdentity = hedgehog $ do+ x <- forAll $ genValidation genSmallText+ (empty <|> x) === x++----------------------------------------------------------------------------+-- Selective instance properties+----------------------------------------------------------------------------++selectiveIdentity :: Property+selectiveIdentity = do+ x <- forAll $ genValidation $ genEither genSmallText genSmallText+ (x <*? pure id) === (either id id <$> x)++selectiveDistributivity :: Property+selectiveDistributivity = do+ x <- forAll $ genEither genInt genInt+ y <- forAllWith (const "y") $ genValidation genFunction+ z <- forAllWith (const "z") $ genValidation genFunction+ (pure x <*? (y *> z)) === ((pure x <*? y) *> (pure x <*? z))++selectiveAssociativity :: Property+selectiveAssociativity = do+ x <- forAll $ genValidation $ genEither genInt genInt+ y <- forAllWith (const "y") $ genValidation $ genEither genInt genFunction+ z <- forAllWith (const "z") $ genValidation genFunction2+ let f = fmap Right+ let g a b = bimap (,b) ($ b) a+ let h = uncurry+ (x <*? (y <*? z)) === ((f <$> x) <*? (g <$> y) <*? (h <$> z))++----------------------------------------------------------------------------+-- Property helpers+----------------------------------------------------------------------------++{- | Property test for the associativity law:++@+a ⊗ (b ⊗ c) ≡ (a ⊗ b) ⊗ c+@+-}+checkAssotiativityFor+ :: (Show a, Eq a)+ => Gen a+ -> (a -> a -> a)+ -> Property+checkAssotiativityFor gen op = hedgehog $ do+ a <- forAll gen+ b <- forAll gen+ c <- forAll gen+ a `op` (b `op` c) === (a `op` b) `op` c
+ test/Test/Properties.hs view
@@ -0,0 +1,21 @@+module Test.Properties+ ( propertiesSpec+ ) where++import Hedgehog (forAll, (===))+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Hedgehog (hedgehog)+import Validation (failures, partitionValidations, successes)++import Test.Gen (Property, genSmallText, genValidationList)+++propertiesSpec :: Spec+propertiesSpec = describe "Validation interface properties" $+ it "partitionValidations x ≡ (failures x, successes x)"+ partitionSpec++partitionSpec :: Property+partitionSpec = hedgehog $ do+ vs <- forAll $ genValidationList genSmallText+ partitionValidations vs === (failures vs, successes vs)
+ validation-selective.cabal view
@@ -0,0 +1,100 @@+cabal-version: 2.4+name: validation-selective+version: 0.0.0.0+synopsis: Lighweight pure data validation based on Applicative and Selective functors+description:+ Lighweight pure data validation based on Applicative and Selective+ functors. The library builds validation interface around the+ following data type:+ .+ @+ __data__ Validation e a+ \ = Failure e+ \ | Success a+ @+ .++homepage: https://github.com/kowainik/validation-selective+bug-reports: https://github.com/kowainik/validation-selective/issues+license: MPL-2.0+license-file: LICENSE+author: Dmitrii Kovanikov, Veronika Romashkina+maintainer: Kowainik <xrom.xkov@gmail.com>+copyright: 2020 Kowainik+category: Validation, Selective, Data+build-type: Simple+extra-doc-files: README.md+ CHANGELOG.md+tested-with: GHC == 8.4.4+ GHC == 8.6.5+ GHC == 8.8.3++source-repository head+ type: git+ location: https://github.com/kowainik/validation-selective.git++common common-options+ build-depends: base >= 4.11.1.0 && < 4.14++ ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies++ default-language: Haskell2010+ default-extensions: ConstraintKinds+ DeriveGeneric+ DerivingStrategies+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ ViewPatterns++library+ import: common-options+ hs-source-dirs: src+ exposed-modules: Validation+ build-depends: deepseq ^>= 1.4.3.0+ , selective >= 0.3 && < 0.5++test-suite validation-selective-test+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Test.Gen+ Test.Laws+ Test.Properties+ build-depends: validation-selective+ , hedgehog ^>= 1.0+ , hspec ^>= 2.7.1+ , hspec-hedgehog ^>= 0.0.1.1+ , selective+ , text ^>= 1.2.4+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N++test-suite validation-selective-doctest+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Doctest.hs+ build-depends: doctest ^>= 0.16+ ghc-options: -threaded