diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,104 @@ +# validation-selective + +![Logo](https://user-images.githubusercontent.com/8126674/76859713-c0880200-6851-11ea-8bc1-bb9dee87d44f.png) +[![GitHub CI](https://github.com/kowainik/validation-selective/workflows/CI/badge.svg)](https://github.com/kowainik/validation-selective/actions) +[![Build status](https://img.shields.io/travis/kowainik/validation-selective.svg?logo=travis)](https://travis-ci.org/kowainik/validation-selective) +[![Windows build status](https://ci.appveyor.com/api/projects/status/github/kowainik/validation-selective?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/validation-selective) + +[![Hackage](https://img.shields.io/hackage/v/validation-selective.svg?logo=haskell)](https://hackage.haskell.org/package/validation-selective) +[![Stackage Lts](http://stackage.org/package/validation-selective/badge/lts)](http://stackage.org/lts/package/validation-selective) +[![Stackage Nightly](http://stackage.org/package/validation-selective/badge/nightly)](http://stackage.org/nightly/package/validation-selective) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](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 +``` diff --git a/src/Validation.hs b/src/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Validation.hs @@ -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 + +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 #-} diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,26 @@ +{- +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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" ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/Test/Gen.hs b/test/Test/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Gen.hs @@ -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 diff --git a/test/Test/Laws.hs b/test/Test/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Test/Laws.hs @@ -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 +-} + +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 diff --git a/test/Test/Properties.hs b/test/Test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties.hs @@ -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) diff --git a/validation-selective.cabal b/validation-selective.cabal new file mode 100644 --- /dev/null +++ b/validation-selective.cabal @@ -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 +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