data-validation (empty) → 0.1.0.0
raw patch · 11 files changed
+1727/−0 lines, 11 filesdep +basedep +containersdep +data-validationsetup-changed
Dependencies added: base, containers, data-validation, hspec, template-haskell
Files
- CHANGELOG.md +5/−0
- LICENSE +191/−0
- README.md +4/−0
- Setup.hs +2/−0
- data-validation.cabal +44/−0
- src/Data/Validation.hs +664/−0
- src/Data/Validation/Internal.hs +76/−0
- src/Data/Validation/Transforms.hs +29/−0
- test/Data/Validation/InternalSpec.hs +208/−0
- test/Data/ValidationSpec.hs +495/−0
- test/Spec.hs +9/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for data-validation + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,191 @@+ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 2020 Alasconnect + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License.
+ README.md view
@@ -0,0 +1,4 @@+# data-validation+A library that simplifies data validation.++Checkout the [examples](https://github.com/alasconnect/data-validation/tree/master/examples/Examples/Data) on github.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ data-validation.cabal view
@@ -0,0 +1,44 @@+cabal-version: 2.4 +name: data-validation +version: 0.1.0.0 +synopsis: A library for creating type safe validations. +description: + A library for creating type safe validations using typeclasses. +homepage: https://github.com/alasconnect/data-validation +license: Apache-2.0 +license-file: LICENSE +author: Alasconnect +maintainer: Alasconnect <software@alasconnect.com> +copyright: 2020 AlasConnect LLC +category: Data +extra-source-files: CHANGELOG.md, README.md + +source-repository head + type: git + location: https://github.com/alasconnect/data-validation + tag: 0.1.0.0 + +library + exposed-modules: Data.Validation + , Data.Validation.Internal + , Data.Validation.Transforms + build-depends: base ^>= 4.12.0.0 + , containers >= 0.6.0 && < 0.7 + , template-haskell >= 2.14.0 && < 2.15 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -v0 + +test-suite test-data-validation + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: Data.ValidationSpec + , Data.Validation.InternalSpec + hs-source-dirs: test + build-depends: base + , containers + , data-validation + , hspec + , template-haskell + default-language: Haskell2010 + ghc-options: -threaded -Wall
+ src/Data/Validation.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE + MultiParamTypeClasses + , FlexibleContexts + , FunctionalDependencies + , TemplateHaskellQuotes +#-} + +module Data.Validation +( -- * Basics +-- $basics + +-- ** Proof +-- $proof + Proof(..) +, fromVCtx +-- ** ValueCtx +-- $valuectx +, ValueCtx(..) +, getValue +, setValue +, withField +, withValue +-- * Validating Primitives +-- $primitives + +-- * Validating Complex Types +-- $complex_types +, Validatable(..) +, validate +-- * Dispute and Refute +-- $dispute_vs_refute +, refute +, refuteMany +, refuteWith +, refuteWithProof +, dispute +, disputeMany +, disputeWith +, disputeWithFact +-- * General Validators +, isRequired +, isLeft +, isRight +, isNull +, isNotNull +, minLength +, maxLength +, isLength +, isEqual +, isNotEqual +, isLessThan +, isLessThanOrEqual +, isGreaterThan +, isGreaterThanOrEqual +, hasElem +, doesNotHaveElem +, ifAny +, ifAll +, ifEach +, ifEachProven +, isMatch +-- * Validation Helpers +, validateField +, optional +, aggregateFailures +, (<!) +, isValid +, isInvalid +-- * Re-exports +, VCtx +, Name +, mkName +, nameBase +) where + +------------------------------------------------------------------------------------------------------------------------ +import Prelude hiding (foldl) +import Data.Bool +import Data.Either (Either(..), rights, lefts) +import Data.Foldable (fold) +import Data.Map hiding (null, fold) +import Data.Maybe +import Language.Haskell.TH (Name, mkName, nameBase) +------------------------------------------------------------------------------------------------------------------------ +import Data.Validation.Internal +------------------------------------------------------------------------------------------------------------------------ + +{- $basics + Validation generally takes the form of `a -> Either f b` where: + + [@a@]: Some unvalidated type. + + [@b@]: Some validated type. + + [@f@]: Some failure type. + + Consider the following example: + + @ + data MyFailures = EmptyEmailAddress | MalformedEmailAddress + validateEmailAddress :: String -> Either MyFailures EmailAddress + @ + + In this case: + + * @a@ ~ 'String' + * @b@ ~ EmailAddress + * @c@ ~ MyFailures + +-} + +{- $proof + + The transformation from `a` to `b` is important and provides a type safe way to prove that validation was successful. + However, rather than using the 'Either' type, this library uses the 'Proof' type. + A 'Proof' represents either a validated type or a collection of failures. + Notice, we use the term validation /failures/ instead of /errors/ + to differentiate between validation and error handling. + The reason we use the 'Proof' type is because it has a custom 'Control.Applicative.Applicative' instance + that will be helpful later. + + The 'Invalid' constructor takes a list of global failures and a map of field failures. + Field failures are useful for identifying a specific field in a record that is invalid. + Fields are identified using a list of 'Language.Haskell.TH.Name' types. + There are two ways to create this type: the @TemplateHaskellQuotes@ extension and the 'Language.Haskell.TH.mkName' function. + + Using the @TemplateHaskellQuotes@ language extension, you can easily create 'Language.Haskell.TH.Name's using a special syntax. + For a records like: + + > data User = User { emailAddress :: String } + + The name can be retrieved by referencing the name with a single quote in front: + + > let name = 'emailAddress + + This allows for the consistant and type safe generation of names. + This method does generate a fully qualified name that includes the module name. + The base name can be accessed using the 'Language.Haskell.TH.nameBase' function. + This extension is considered safe Haskell while the @TemplateHaskell@ extension is not. + See <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/template_haskell.html#syntax> for details. + + Another approach is to use the 'Language.Haskell.TH.mkName' function. + This allows field names to be generated for non-record types. + However, it does require managing magic strings. + + To finish our discussion on the 'Proof' type, the reason the key is a list of names is because of subfields. + Consider a record like this: + + @ + data Contact = Contact { phoneNumber :: String } + + data User + = User + { username :: String + , contact :: Contact + } + @ + + In this case, validating the `User` type requires validating the `contact` field which is a `Contact`. + In that case, the key would need to identify that the `phoneNumber` field is a subfield of `contact`. + The key would look like this: + + >> ['contact, 'phoneNumber] +-} + +-- | A type that holds either validation failures or a validated value. +data Proof f a + = Valid a -- ^ A validated value. + | Invalid [f] (Map [Name] [f]) -- ^ Global and field validation failures. + deriving (Show, Eq) + +instance Semigroup a => Semigroup (Proof f a) where + (Valid a1) <> (Valid a2) = Valid (a1 <> a2) + (Invalid gfs1 lfs1) <> (Invalid gfs2 lfs2) = Invalid (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) + (Valid _) <> (Invalid gfs lfs) = Invalid gfs lfs + (Invalid gfs lfs) <> (Valid _) = Invalid gfs lfs + +instance Monoid a => Monoid (Proof f a) where + mempty = Valid mempty + +instance Functor (Proof f) where + fmap fn (Valid a) = Valid (fn a) + fmap _ (Invalid gps lps) = Invalid gps lps + +instance Applicative (Proof f) where + pure = Valid + (Invalid gfs1 lfs1) <*> (Invalid gfs2 lfs2) = Invalid (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) + (Invalid gfs lfs) <*> (Valid _) = Invalid gfs lfs + (Valid _) <*> (Invalid gfs lfs) = Invalid gfs lfs + Valid fn <*> Valid a = Valid $ fn a + +instance Monad (Proof f) where + (Invalid gfs lfs) >>= _ = Invalid gfs lfs + (Valid a) >>= fn = fn a + +{- | Converts a 'Data.Validation.Internal.VCtx' to a 'Proof'. + + Internally, this library uses the 'Data.Validation.Internal.VCtx' type to track validation failures. + This is because a validation failure can be partial. + For instance, checking that a password has a special character can happen even if the check for a numeric character + has already failed. + This allows validation to discover as many failures as possible. + + However, once validation is complete, the result becomes binary. + The validation has either succeeded or failed. + In order to convert from a 'Data.Validation.Internal.VCtx' to a 'Proof', use the 'fromVCtx' function. +-} +fromVCtx :: VCtx f a -> Proof f a +fromVCtx (ValidCtx a) = Valid a +fromVCtx (DisputedCtx gfs lfs _) = Invalid gfs lfs +fromVCtx (RefutedCtx gfs lfs) = Invalid gfs lfs + +{- $valuectx + This library uses composable validations. + As such, we need a type that carries information about the thing being validated. + Specifically, we need a type to carry its value and, optionally, its name. + + A value with a name is a field and will be used to create field failures. + A value without a name will be used to create global failures. + This is accomplished using the 'ValueCtx' type. + + The 'withField' and 'withValue' functions are used to create these types and perform validation at the same time. + These functions save the effort of wrapping and unwrapping values with the 'ValueCtx' type. +-} + +-- | A type for storing a value to validate and, optionally, its field name. +data ValueCtx a + = Field Name a -- ^ The 'Field' constructor represents a value that is named. + | Global a -- ^ The 'Global' constructor represents a value that is not named. + deriving (Show, Eq) + +instance Functor ValueCtx where + fmap fn (Field n a) = Field n (fn a) + fmap fn (Global a) = Global (fn a) + +-- | Accessor for a 'ValueCtx''s value. +getValue :: ValueCtx a -> a +getValue (Field _ a) = a +getValue (Global a) = a + +-- | Replaces the existing value with a new one without changing the name, if one exists. +setValue :: ValueCtx a -> b -> ValueCtx b +setValue (Field n _) b = Field n b +setValue (Global _) b = Global b + +-- | Performs some given validation using a 'Field' with a given name and value. +withField :: Name -> a -> (ValueCtx a -> VCtx f (ValueCtx b)) -> VCtx f b +withField n a fn = fn (Field n a) >>= pure . getValue + +-- | Performs some given validation using a 'Global' with a given value. +withValue :: a -> (ValueCtx a -> VCtx f (ValueCtx b)) -> VCtx f b +withValue a fn = fn (Global a) >>= pure . getValue + +{- $primitives + Validating primitives is a special case because the validated type and unvalidated type are often the same. + An email address is just a specially formatted string, so both the unvalidated email address and the validated one have the same types. + To get around this, you can wrap a primitive in a `newtype`, hide the constructor, and create a smart constructor that validates the input. + This allows for a kind of type safety known as `correct by construction`. + Consider the following example. + + @ + module Primitives + ( MyFailures + , EmailAddress -- the constructors are not exported + , mkEmailAddress + ) where + + data MyFailures = EmptyEmail | + + mkEmailAddress :: String -> Proof MyFailures EmailAddress + mkEmailAddress s = fromVCtx $ do -- (1) + v \<- withValue s $ \\v -> do -- (2) + isNotNull EmptyEmail v -- (3) + disputeWithFact InvalidEmail (elem '@') v -- (4) + return $ EmailAddress v -- (5) + @ + + Starting with line (2), the 'withValue' function is used to create a 'ValueCtx' using string passed into the function. + The lambda function that follows takes the 'ValueCtx' and runs it through several validators using `do` syntax. + This is possible because 'VCtx' has a 'Monad' instance. + + Line (1) transforms the result from a 'VCtx' to a 'Proof' as discussed above. + + Line (3) and (4) demonstrate both a general validator and a custom validator. + These will be covered in more detail later. + + Line (5) constructs the `EmailAddress` type and returns it. + If any validation failures occur before this point, an 'Invalid' result is generated instead of the `EmailAddress`. + + It is important to note that no instances should be created for the `EmailAddress` type that allow construction. + This includes the `FromJSON` type class from the `aeson` library. +-} + +{- $complex_types + In general, validating complex types works the same way as validating primitives. + It starts with an unvalidated type that is transformed into a validated type. + These unvalidated types are often called "view models". + View models should be transformed into models when they are validated. + So, like primitives, validating complex types should have the form validate :: a -> Proof f b. + + For complex types, this can be accomplished with the 'Validatable f a b' type class. + This type class takes 3 parameters: the failure type, the view model type, and the final model type. + It requires the implementation of a single function: 'validation'. + Then the 'validate' function can be used to perform the actual validation. + Consider the following example: + + @ + -- unvalidated type + data UserCreatableVM + = UserCreatableVM + { userCreatableVMEmailAddress :: String + , userCreatableVMConfirmEmailAddress :: String + , userCreatableVMPassword :: String + , userCreatableVMConfirmPassword :: String + , userCreatableVMName :: Maybe String + } + + -- validated type + data UserCreatable + = UserCreatable -- (1) + { userCreatableEmailAddress :: EmailAddress + , userCreatablePassword :: Password + , userCreatableName :: Maybe Name + } + + instance Validatable MyFailureType UserCreatableVM UserCreatable where -- (2) + validation u = + let ve = withField 'userCreatableVMEmailAddress (userCreatableVMEmailAddress u) $ + refuteWithProof mkEmailAddress -- (3) + vce = withField 'userCreatableVMConfirmEmailAddress (userCreatableVMConfirmEmailAddress u) $ + \\ce -> refuteWithProof mkEmailAddress ce + >>= isMatch MismatchedEmail ve -- (4) + vp = withField 'userCreatableVMPassword (userCreatableVMPassword u) $ + refuteWithProof mkPassword + vcp = withField 'userCreatableVMConfirmPassword (userCreatableVMConfirmPassword u) $ + \\ce -> refuteWithProof mkPassword ce + >>= isMatch MismatchedPassword vp + vn = optional (userCreatableVMName u) $ \\n -> + withField 'userCreatableVMName n $ refuteWithProof mkName + otherCheck = withValue u nameNotInPassword + in pure UserCreatable \<*> ve \<*> vp \<*> vn <! vce <! vcp <! otherCheck -- (5) + where nameNotInPassword = ... + @ + + The final model does not have all of the same fields on line (1). + The confirmation fields were removed because they serve no purpose beyond validation. + + The validation function is implemented much like the smart constructors in the previous section. + However, it is using the 'withField' function instead of 'withValue'. + In addition, there is no call to 'fromVCtx' because validation is expected to return a 'VCtx'. + Another function, 'validate', will use these validations to produce a 'Proof'. + + On line (2), the 'Validatable' instance is declared with an application specific failure type. + The second and third parameter are the view model and final model types. + This represents the transformation from the unvalidated type to the validated types. + + On line (3), there is a call to 'refuteWithProof' which validates and constructs a primitive using the smart constructor from the previous example. + Line (4) uses the 'isMatch' function to prove that the email address and confirm email address fields match. + The function accepts a 'VCtx' to match against making it very easy to compare validated field. + + Finally, line (5) is a bit interesting. + It constructs the final type using applicative syntax. + It uses the applicative instance on 'VCtx' to construct the final type. + If all of the parameters are valid, the expression returns a valid `UserCreatable`. + However, if any of the parameters are invalid, the whole expression becomes invalid and contains every failure from every field. + This creates the aggregated result. + + There is also a call to the '(<!)' function. + This function is read as 'aggregateFailures'. + In English, it takes the failures from the second parameter, if any, and adds them to the first. + This allows the aggregation of failures from fields that are not included in the final type. +-} + +-- | A type class that represents a value that can be validated. +-- +-- The parameters represent the following: +-- * `f`: the type of validation failures. +-- * `a`: the unvalidated type or view model. +-- * `b`: the validated type. +class Validatable f a b | a -> f b where + validation :: a -> VCtx f b + +-- | Runs the validations for a given value and returns the proof. +validate :: Validatable f a b => a -> Proof f b +validate = fromVCtx . validation + +{- $dispute_vs_refute + Refuting a value stops all validation efforts on the value. + This means that any future failures that could have been detected will not. + Dispute, on the other hand, will allow validation to continue. + So, why should one be chosen over the other? + + First, we have to look at how validation works. + Validation transforms values from an unvalidated type to a validated type. + So, when a value is being passed through a validation chain, it is being transformed. + If a validation fails, the transform fails too; there is no way around this. + The new value cannot be retrieved from the validation if it failed. + + Consider a @'Maybe' 'String'@ value that is required and must be at least 3 characters long. + First, the value would pass through the 'isRequired' validator. + If the value is a @'Just' a@, validation succeeds and the value a is passed to the next validator which checks its length. + If the value is a 'Nothing', it is not possible to check its length. + Therefore, the validation must be refuted. + A refuted value results in an invalid 'Proof' but stops the execution of any further validation. + + Now, consider an 'Int' value that must be greater than 2 and even. + First, the value would pass though the 'minValue' validator. + If the value is greater than 2, validation succeeds and the `isEven` validator is called. + If the value is 2 or less, the validation fails. + However, rather than fail completely, the next validator can just use the same value that was passed into the 'minValue' validator. + In that case, the validator should dispute the value so that the next validator can be run. + This will still result in an invalid 'Proof' but allows for more failures to be detected. + + In general, if a validator has the form @a -> 'Either' f b@, a failure must be refuted because they transform the value. + If it has the form @a -> 'Maybe' f@, it should be disputed because it does not transform the value. +-} + +-- | Adds a validation failure to the result and ends validation. +refute :: ValueCtx a -> f -> VCtx f b +refute (Field n _) f = RefutedCtx [] (singleton [n] [f]) +refute (Global _) f = RefutedCtx [f] empty + +-- | Adds validation failures to the result and ends validation. +refuteMany :: ValueCtx a -> [f] -> VCtx f b +refuteMany (Field n _) fs = RefutedCtx [] (singleton [n] fs) +refuteMany (Global _) fs = RefutedCtx fs empty + +-- | Adds a validation failure to the result and continues validation. +dispute :: ValueCtx a -> f -> VCtx f (ValueCtx a) +dispute v@(Field n _) f = DisputedCtx [] (singleton [n] [f]) v +dispute v@(Global _) f = DisputedCtx [f] empty v + +-- | Adds validation failures to the result and continues validation. +disputeMany :: ValueCtx a -> [f] -> VCtx f (ValueCtx a) +disputeMany v@(Field n _) fs = DisputedCtx [] (singleton [n] fs) v +disputeMany v@(Global _) fs = DisputedCtx fs empty v + +-- | Performs a validation using a given function and handles the result. +-- If the result is `Just f`, a validation failure is added to the result and validation continues. +-- If the result is `Nothing`, validation continues with no failure. +disputeWith :: (a -> Maybe f) -> ValueCtx a -> VCtx f (ValueCtx a) +disputeWith fn v = case fn (getValue v) of + Just f -> dispute v f + Nothing -> pure v + +-- | Similar to 'disputeWith' except that the given failure is added if the given function returns False. +disputeWithFact :: f -> (a -> Bool) -> ValueCtx a -> VCtx f (ValueCtx a) +disputeWithFact f fn = disputeWith (bool (Just f) Nothing . fn) + +-- | Performs a validation using a given function and handles the result. +-- If the result is `Left f`, a validation failure is added to the result and validation ends. +-- If the result is `Right b`, validation continues with the new value. +refuteWith :: (a -> Either f b) -> ValueCtx a -> VCtx f (ValueCtx b) +refuteWith fn v = case fn (getValue v) of + Left f -> refute v f + Right b -> pure $ setValue v b + +-- | Performs a validation using a given function and handles the result. +-- If the result is 'Invalid', the validation failures are added to the result and validation ends. +-- If the result is `Valid b`, validation continues with the new value. +refuteWithProof :: (a -> Proof f b) -> ValueCtx a -> VCtx f (ValueCtx b) +refuteWithProof f (Global a) = case f a of + Invalid gfs lfs -> RefutedCtx gfs lfs + Valid b -> ValidCtx $ Global b +refuteWithProof f (Field n a) = case f a of + Invalid gfs lfs -> RefutedCtx [] $ insert [n] gfs lfs + Valid b -> ValidCtx $ Field n b + +-- General Validators + +-- | Checks that a 'Data.Maybe.Maybe' value is a 'Data.Maybe.Just'. +-- If not, it adds the given failure to the result and validation end. +isRequired :: f -> ValueCtx (Maybe a) -> VCtx f (ValueCtx a) +isRequired f = refuteWith $ \ma -> case ma of + Nothing -> Left f + Just a -> Right a + +-- | Checks that a 'Data.Either.Either' value is a 'Data.Either.Left'. +-- If not, it adds the given failure to the result and validation end. +isLeft :: f -> ValueCtx (Either a b) -> VCtx f (ValueCtx a) +isLeft f = refuteWith $ \e -> case e of + Left a -> Right a + Right _ -> Left f + +-- | Checks that a 'Data.Either.Either' value is a 'Data.Either.Right'. +-- If not, it adds the given failure to the result and validation end. +isRight :: f -> ValueCtx (Either a b) -> VCtx f (ValueCtx b) +isRight f = refuteWith $ \e -> case e of + Right b -> Right b + Left _ -> Left f + +-- | Checks that the 'Foldable' is empty. +-- If so, it adds the given failure to the result and validation continues. +isNull :: Foldable t => f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +isNull f = disputeWith $ bool (Just f) Nothing . null + +-- | Checks that the 'Foldable' is not empty. +-- If not, it adds the given failure to the result and validation continues. +isNotNull :: Foldable t => f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +isNotNull f = disputeWith $ bool (Just f) Nothing . not . null + +-- | Checks that a 'IsString' has a length equal to or grater than the given value. +-- If not, it adds the given failure to the result and validation continues. +minLength :: Foldable t => Int -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +minLength l f = disputeWith $ bool (Just f) Nothing . (<=) l . length + +-- | Checks that a 'IsString' has a length equal to or less than the given value. +-- If not, it adds the given failure to the result and validation continues. +maxLength :: Foldable t => Int -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +maxLength l f = disputeWith $ bool (Just f) Nothing . (>=) l . length + +-- | Checks that a 'IsString' has a length equal the given value. +-- If not, it adds the given failure to the result and validation continues. +isLength :: Foldable t => Int -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +isLength l f = disputeWith $ bool (Just f) Nothing . (==) l . length + +-- | Checks that a value is equal to another. +-- If not, it adds the given failure to the result and validation continues. +isEqual :: Eq a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a) +isEqual a f = disputeWith $ bool (Just f) Nothing . (==) a + +-- | Checks that a value is not equal to another. +-- If not, it adds the given failure to the result and validation continues. +isNotEqual :: Eq a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a) +isNotEqual a f = disputeWith $ bool (Just f) Nothing . (/=) a + +-- | Checks that a value is less than to another. +-- If not, it adds the given failure to the result and validation continues. +isLessThan :: Ord a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a) +isLessThan a f = disputeWith $ bool (Just f) Nothing . (>) a + +-- | Checks that a value is greater than to another. +-- If not, it adds the given failure to the result and validation continues. +isGreaterThan :: Ord a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a) +isGreaterThan a f = disputeWith $ bool (Just f) Nothing . (<) a + +-- | Checks that a value is less than or equal to another. +-- If not, it adds the given failure to the result and validation continues. +isLessThanOrEqual :: Ord a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a) +isLessThanOrEqual a f = disputeWith $ bool (Just f) Nothing . (>=) a + +-- | Checks that a value is greater than or equal to another. +-- If not, it adds the given failure to the result and validation continues. +isGreaterThanOrEqual :: Ord a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a) +isGreaterThanOrEqual a f = disputeWith $ bool (Just f) Nothing . (<=) a + +-- | Checks that a 'Foldable' has a given element. +-- If not, it adds the given failure to the result and validation continues. +hasElem :: (Foldable t, Eq a) => a -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +hasElem e f = disputeWith $ bool (Just f) Nothing . elem e + +-- | Checks that a 'Foldable' does not have a given element. +-- If not, it adds the given failure to the result and validation continues. +doesNotHaveElem :: (Foldable t, Eq a) => a -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a)) +doesNotHaveElem e f = disputeWith $ bool (Just f) Nothing . not . elem e + +-- | If any element is valid, the entire value is valid. +ifAny :: (a -> Maybe f) -> ValueCtx [a] -> VCtx f (ValueCtx [a]) +ifAny fn v = + let + xs = getValue v + fs = catMaybes $ fmap fn xs + in if length fs == length xs + then disputeMany v fs + else pure v + +-- | Every element must be valid. +ifAll :: (a -> Maybe f) -> ValueCtx [a] -> VCtx f (ValueCtx [a]) +ifAll fn v = case catMaybes . fmap fn $ getValue v of + [] -> pure v + fs -> disputeMany v fs + +-- | Validate each element with a given function. +ifEach :: (a -> Either f b) -> ValueCtx [a] -> VCtx f (ValueCtx [b]) +ifEach fn v = + let es = fmap fn $ getValue v + in case lefts es of + [] -> pure . setValue v $ rights es + fs -> refuteMany v fs + +-- | Validate each element with a given function. +ifEachProven :: (a -> Proof f b) -> ValueCtx [a] -> VCtx f (ValueCtx [b]) +ifEachProven fn v = + let p = fold $ fmap (fmap (\b -> [b]) . fn) $ getValue v + in case p of + Valid es -> pure $ setValue v es + Invalid gfs lfs -> case v of + Global _ -> RefutedCtx gfs lfs + Field n _ -> RefutedCtx [] $ insert [n] gfs lfs + +-- | Checks that two fields are equal. +-- If not, it adds the given failure to the result and validation continues. +isMatch :: Eq a => f -> VCtx f a -> ValueCtx a -> VCtx f (ValueCtx a) +isMatch f (ValidCtx a) = disputeWith (testMatch f a) +isMatch f (DisputedCtx _ _ a) = disputeWith (testMatch f a) +isMatch _ (RefutedCtx _ _) = pure + +{- | Validates a value that implements 'Validatable' and includes any failures under the parent field. + +Consider the following example: + +@ + data ContactVM = ContactVM { phoneNumber :: String } + data Contact = ... + instance Validatable MyFailureType ContactVM Contact where + ... + + data UserCreatableVM + = UserCreatableVM + { userCreatableVMEmailAddress :: String + , userCreatableVMConfirmEmailAddress :: String + , userCreatableVMPassword :: String + , userCreatableVMConfirmPassword :: String + , userCreatableVMContact :: ContactVM + } + data UserCreatable = ... + + instance Validatable MyFailureType UserCreatableVM UserCreatable where + validation u = + let vc = withField 'userCreatableVMContact (userCreatableVMContact u) $ + validateField -- (1) + ... + in pure UserCreatable \<*> ve \<*> vp \<*> vc <! vce <! vcp + @ + + In line (1), the 'validateField' function uses the 'Validatable' instance on `ContactVM` to validate the type. + All field specific validation failures are stored in a map where the key is the name of the field. + However, in this case, there are the fields in the `ContactVM` and the parent field in `UserCreatableVM`. + These names need to be combined so that the consumer can see if any errors came from nested fields. + Using the 'validateField' function, any validation failures found in the `ContactVM` value have field names that include the parent field. + A `ContactVM` with an invalid phone number might have a result like this: `Invalid [] [(['phoneNumber], [InvalidPhoneNumber])]` where `['phoneNumber]` is the key to the map. + The 'validationField' merges this with the `UserCreatable` result to create something like this: `Invalid [] [(['contact, 'phoneNumber], [InvalidPhoneNumber])]`. + This allows the consumer to determine exactly what field caused the failure. +-} +validateField :: Validatable f a b => ValueCtx a -> VCtx f (ValueCtx b) +validateField (Global a) = case validation a of + ValidCtx b -> ValidCtx (Global b) + DisputedCtx gfs lfs b -> DisputedCtx gfs lfs (Global b) + RefutedCtx gfs lfs -> RefutedCtx gfs lfs +validateField (Field n a) = case validation a of + ValidCtx b -> ValidCtx (Field n b) + DisputedCtx [] lfs b -> DisputedCtx [] (mapKeys (\k -> [n] ++ k) lfs) (Field n b) + DisputedCtx gfs lfs b -> DisputedCtx [] (insert [n] gfs $ mapKeys (\k -> [n] ++ k) lfs) (Field n b) + RefutedCtx [] lfs -> RefutedCtx [] (mapKeys (\k -> [n] ++ k) lfs) + RefutedCtx gfs lfs -> RefutedCtx [] (insert [n] gfs $ mapKeys (\k -> [n] ++ k) lfs) + +-- | Allows for validation of an optional value. +-- See `Validating Complex Types` for an example. +optional :: Maybe a -> (a -> VCtx f b) -> VCtx f (Maybe b) +optional Nothing _ = ValidCtx Nothing +optional (Just a) f = + case f a of + ValidCtx b -> ValidCtx (Just b) + DisputedCtx gfs lfs b -> DisputedCtx gfs lfs (Just b) + RefutedCtx gfs lfs -> RefutedCtx gfs lfs + +-- | tests if a 'Proof' is valid. +isValid :: Proof f a -> Bool +isValid (Valid _) = True +isValid (Invalid _ _) = False + +-- | tests if a 'Proof' is invalid. +isInvalid :: Proof f a -> Bool +isInvalid = not . isValid
+ src/Data/Validation/Internal.hs view
@@ -0,0 +1,76 @@+module Data.Validation.Internal where++------------------------------------------------------------------------------------------------------------------------+import Prelude+import Data.Map+import Language.Haskell.TH (Name)+------------------------------------------------------------------------------------------------------------------------++-- | A type that holds aggregated validation failures.+data VCtx f a + = ValidCtx a -- ^ A value that is assumed to be valid.+ | DisputedCtx [f] (Map [Name] [f]) a -- ^ A value that has failures but can continue to be validated.+ | RefutedCtx [f] (Map [Name] [f]) -- ^ A value that has failures and cannot be validated further.+ deriving (Show, Eq)++instance Semigroup a => Semigroup (VCtx f a) where+ (ValidCtx a1) <> (ValidCtx a2) = ValidCtx (a1 <> a2)+ (ValidCtx a1) <> (DisputedCtx gfs lfs a2) = DisputedCtx gfs lfs (a1 <> a2)+ (ValidCtx _) <> (RefutedCtx gfs lfs) = RefutedCtx gfs lfs+ (DisputedCtx gfs lfs a1) <> (ValidCtx a2) = DisputedCtx gfs lfs (a1 <> a2)+ (DisputedCtx gfs1 lfs1 a1) <> (DisputedCtx gfs2 lfs2 a2) = + DisputedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) (a1 <> a2)+ (DisputedCtx gfs1 lfs1 _) <> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)+ (RefutedCtx gfs lfs) <> (ValidCtx _) = RefutedCtx gfs lfs+ (RefutedCtx gfs1 lfs1) <> (DisputedCtx gfs2 lfs2 _) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)+ (RefutedCtx gfs1 lfs1) <> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)++instance Monoid a => Monoid (VCtx f a) where+ mempty = ValidCtx mempty++instance Functor (VCtx f) where+ fmap f (ValidCtx a) = ValidCtx (f a)+ fmap f (DisputedCtx gps lfs a) = DisputedCtx gps lfs (f a)+ fmap _ (RefutedCtx gps lfs) = RefutedCtx gps lfs++instance Applicative (VCtx f) where+ pure = ValidCtx+ (ValidCtx fn) <*> (ValidCtx a) = ValidCtx (fn a)+ (ValidCtx fn) <*> (DisputedCtx gfs lfs a) = DisputedCtx gfs lfs (fn a)+ (ValidCtx _) <*> (RefutedCtx gfs lfs) = RefutedCtx gfs lfs+ (DisputedCtx gfs lfs fn) <*> (ValidCtx a) = DisputedCtx gfs lfs (fn a)+ (DisputedCtx gfs1 lfs1 fn) <*> (DisputedCtx gfs2 lfs2 a) = + DisputedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) (fn a)+ (DisputedCtx gfs1 lfs1 _) <*> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)+ (RefutedCtx gfs lfs) <*> (ValidCtx _) = RefutedCtx gfs lfs+ (RefutedCtx gfs1 lfs1) <*> (DisputedCtx gfs2 lfs2 _) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)+ (RefutedCtx gfs1 lfs1) <*> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)++instance Monad (VCtx f) where+ (ValidCtx a) >>= fn = fn a+ (RefutedCtx gfs lfs) >>= _ = RefutedCtx gfs lfs+ (DisputedCtx gfs lfs a) >>= fn = case fn a of+ ValidCtx b -> DisputedCtx gfs lfs b+ DisputedCtx gfs' lfs' b -> DisputedCtx (gfs <> gfs') (unionWith (<>) lfs lfs') b+ RefutedCtx gfs' lfs' -> RefutedCtx (gfs <> gfs') (unionWith (<>) lfs lfs')++-- | Takes the failures from the second parameter and adds them to the first.+aggregateFailures :: VCtx f a -> VCtx f b -> VCtx f a+aggregateFailures a b = a <! b++-- | Takes the failures from the right-hand-side, if any, and adds them to the left-hand-side.+(<!) :: VCtx f a -> VCtx f b -> VCtx f a+(ValidCtx a) <! (ValidCtx _) = ValidCtx a+(ValidCtx a) <! (DisputedCtx gfs lfs _) = DisputedCtx gfs lfs a+(ValidCtx _) <! (RefutedCtx gfs lfs) = RefutedCtx gfs lfs+(DisputedCtx gfs lfs a) <! (ValidCtx _) = DisputedCtx gfs lfs a+(DisputedCtx gfs1 lfs1 a) <! (DisputedCtx gfs2 lfs2 _) = DisputedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) a+(DisputedCtx gfs1 lfs1 _) <! (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)+(RefutedCtx gfs lfs) <! (ValidCtx _) = RefutedCtx gfs lfs+(RefutedCtx gfs1 lfs1) <! (DisputedCtx gfs2 lfs2 _) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)+(RefutedCtx gfs1 lfs1) <! (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)++testMatch :: Eq a => f -> a -> a -> Maybe f+testMatch f a1 a2 = case a1 == a2 of+ True -> Nothing+ False -> Just f
+ src/Data/Validation/Transforms.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TypeFamilies #-} + +module Data.Validation.Transforms where + +-- | A type that represents a validated type. +data V +-- | A type that represents an unvalidated type, often called a View Model. +data VM + +-- | A type that represents a validation transformaion. +-- The unvalidated type is the first parameter which is used when 'VM' is passed in. +-- The second parameter is the validated type which is used when 'V' is passed in. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- @ +-- data ThingV v +-- = Thing +-- { emailAddress :: VT v String EmailAddress +-- , confirmEmailAddress :: VT v String () +-- } +-- type ThingVM = ThingV VM -- A `Thing` view model. +-- type Thing = ThingV V -- A validated `Thing`. +-- @ +type family VT v a b where + VT V a b = b + VT VM a b = a
+ test/Data/Validation/InternalSpec.hs view
@@ -0,0 +1,208 @@+module Data.Validation.InternalSpec where + +------------------------------------------------------------------------------------------------------------------------ +import Test.Hspec +import Data.Map (fromList) +import Language.Haskell.TH +------------------------------------------------------------------------------------------------------------------------ +import Data.Validation.Internal +------------------------------------------------------------------------------------------------------------------------ + +spec :: Spec +spec = parallel $ do + + describe "Semigroup (VCtx f a)" $ do + it "If applied to two valid contexts, it concatenate the inhabitants." $ do + ValidCtx [1] <> ValidCtx [2] `shouldBe` (ValidCtx [1,2] :: VCtx String [Int]) + + it "If applied to an valid and disputed contexts, it results in the disputed context concatenated with the valid context." $ do + let + mkDis = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + ValidCtx [1] <> (mkDis [2] :: VCtx String [Int]) `shouldBe` mkDis [1,2] + + it "If applied to an valid and refuted contexts, it results in the refuted context." $ do + let + r = RefutedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + ValidCtx [1] <> (r :: VCtx String [Int]) `shouldBe` r + + it "If applied to a disputed and valid context, it results in the disputed context concatenated with the valid context." $ do + let + mkDis = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + mkDis [1] <> (ValidCtx [2] :: VCtx String [Int]) `shouldBe` mkDis [1,2] + + it "If applied to two disputed contexts, it concatenates the contexts." $ do + let + v1 = DisputedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) [1] + v2 = DisputedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) [2] + v3 = DisputedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) [1,2] + (v1 :: VCtx String [Int]) <> v2 `shouldBe` v3 + + it "If applied to a disputed and refuted context, it results in the refuted context." $ do + let + v1 = DisputedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) [1] + v2 = RefutedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) + v3 = RefutedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) + (v1 :: VCtx String [Int]) <> v2 `shouldBe` v3 + + it "If applied to a refuted and valid context, it results in the refuted context." $ do + let + r = RefutedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + r <> (ValidCtx [1] :: VCtx String [Int]) `shouldBe` r + + it "If applied to a refuted and disputed context, it concatenates the failures and results in a refuted context." $ do + let + v1 = RefutedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) + v2 = DisputedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) [2] + v3 = RefutedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) + (v1 :: VCtx String [Int]) <> v2 `shouldBe` v3 + + it "If applied to two refuted contexts, it concatenates the failures." $ do + let + v1 = RefutedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) + v2 = RefutedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) + v3 = RefutedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) + (v1 :: VCtx String [Int]) <> v2 `shouldBe` v3 + + describe "Functor (VCtx f)" $ do + it "Converts a `VCtx f a` to a `VCtx f b`." $ do + fmap show (ValidCtx 1 :: VCtx String Int) `shouldBe` ValidCtx "1" + + it "Updates the value in a disputed context while preserving failures." $ do + let + v1 = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) 1 + v2 = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) "1" + fmap show (v1 :: VCtx String Int) `shouldBe` (v2 :: VCtx String String) + + it "Does not change the contents of an refuted context." $ do + let v = RefutedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + fmap show (v :: VCtx String Int) `shouldBe` (v :: VCtx String String) + + describe "Applicative (VCtx f)" $ do + let + vac = ValidCtx show :: VCtx String (Int -> String) + dac = DisputedCtx ["Applicative Failure"] mempty show :: VCtx String (Int -> String) + rac = RefutedCtx ["Applicative Failure"] mempty :: VCtx String (Int -> String) + vc = ValidCtx 1 :: VCtx String Int + dc = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) 1 :: VCtx String Int + rc = RefutedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + + it "Constructs a new valid context" $ do + pure 1 `shouldBe` (ValidCtx 1 :: VCtx String Int) + + it "If applied to two valid contexts, it maps the function of the inhabitants." $ do + vac <*> vc `shouldBe` ValidCtx "1" + + it "If applied to an valid and disputed contexts, it maps the function over the inhabitants while preserving failures." $ do + vac <*> dc `shouldBe` DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) "1" + + it "If applied to an valid and refuted contexts, it results in the refuted context." $ do + vac <*> rc `shouldBe` (rc :: VCtx String String) + + it "If applied to a disputed and valid context, it maps the function over the inhabitants while preserving failures." $ do + dac <*> vc `shouldBe` DisputedCtx ["Applicative Failure"] mempty "1" + + it "If applied to two disputed contexts, it maps the function over the inhabitants while concatenating the failures." $ do + dac <*> dc `shouldBe` DisputedCtx ["Applicative Failure", "Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) "1" + + it "If applied to a disputed and refuted context, it results in the refuted context." $ do + dac <*> rc `shouldBe` RefutedCtx ["Applicative Failure", "Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + + it "If applied to a refuted and valid context, it results in the refuted context." $ do + rac <*> vc `shouldBe` RefutedCtx ["Applicative Failure"] mempty + + it "If applied to a refuted and disputed context, it concatenates the failures and results in a refuted context." $ do + rac <*> dc `shouldBe` RefutedCtx ["Applicative Failure", "Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + + it "If applied to two refuted contexts, it concatenates the failures." $ do + rac <*> rc `shouldBe` RefutedCtx ["Applicative Failure", "Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + + describe "Monad (VCtx f)" $ do + it "Binds a valid context to a function." $ do + ((ValidCtx 1 :: VCtx String Int) >>= pure . show) `shouldBe` ValidCtx "1" + + it "Binds a disputed context to a function while preserving failures." $ do + ((DisputedCtx ["Failure"] mempty 1 :: VCtx String Int) >>= pure . show) `shouldBe` DisputedCtx ["Failure"] mempty "1" + + it "Does not change the contents of a refuted context." $ do + ((RefutedCtx ["Failure"] mempty :: VCtx String Int) >>= pure . show) `shouldBe` RefutedCtx ["Failure"] mempty + + + describe "(<!)" $ do + let + one = 1 :: Int + two = 2 :: Int + + it "If applied to two valid contexts, it selects the first." $ do + ValidCtx [one] <! ValidCtx [two] `shouldBe` (ValidCtx [one] :: VCtx String [Int]) + + it "If applied to an valid and disputed contexts, it results in the disputed context using the value of the first." $ do + let + mkDis = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + ValidCtx [one] <! (mkDis [two] :: VCtx String [Int]) `shouldBe` mkDis [one] + + it "If applied to an valid and refuted contexts, it results in the refuted context." $ do + let + r = RefutedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + ValidCtx [one] <! (r :: VCtx String [Int]) `shouldBe` r + + it "If applied to a disputed and valid context, it results in the disputed context." $ do + let + d = DisputedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) [one] + d <! (ValidCtx [two] :: VCtx String [Int]) `shouldBe` d + + it "If applied to two disputed contexts, it concatenates the failures and selects the value from the first." $ do + let + v1 = DisputedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) [one] + v2 = DisputedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) [two] + v3 = DisputedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) [one] + v1 <! v2 `shouldBe` v3 + + it "If applied to a disputed and refuted context, it results in a refuted context with the failures from both." $ do + let + v1 = DisputedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) [one] + v2 = RefutedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) + v3 = RefutedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) + v1 <! v2 `shouldBe` v3 + + it "If applied to a refuted and valid context, it results in the refuted context." $ do + let + r = RefutedCtx ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) :: VCtx String String + r <! (ValidCtx [2] :: VCtx String [Int]) `shouldBe` r + + it "If applied to a refuted and disputed context, it concatenates the failures and results in a refuted context." $ do + let + v1 = RefutedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) + v2 = DisputedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) [two] + v3 = RefutedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) + (v1 :: VCtx String [Int]) <! v2 `shouldBe` v3 + + it "If applied to two refuted contexts, it concatenates the failures." $ do + let + v1 = RefutedCtx ["Failure1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) + v2 = RefutedCtx ["Failure2"] + (fromList [([mkName "Field2"], ["Field Failure 2"])]) + v3 = RefutedCtx ["Failure1", "Failure2"] + (fromList [([mkName "Field1"], ["Field Failure 1"]), ([mkName "Field2"], ["Field Failure 2"])]) + (v1 :: VCtx String [Int]) <! v2 `shouldBe` v3
+ test/Data/ValidationSpec.hs view
@@ -0,0 +1,495 @@+{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , TemplateHaskellQuotes + , TypeSynonymInstances +#-} + +module Data.ValidationSpec where + +------------------------------------------------------------------------------------------------------------------------ +import Test.Hspec +import Data.Bool (bool) +import Data.Map (fromList) +import Text.Read (readEither) +------------------------------------------------------------------------------------------------------------------------ +import Data.Validation +import Data.Validation.Internal +------------------------------------------------------------------------------------------------------------------------ + +spec :: Spec +spec = parallel $ do + + describe "Semigroup (Proof f a)" $ do + it "If applied to two valid proofs, it concatenate the inhabitants." $ do + Valid [1] <> Valid [2] `shouldBe` (Valid [1,2] :: Proof String [Int]) + + it "If applied to an invalid and valid proof, it results in the invalid proof." $ do + let + vi = Invalid ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + (vi :: Proof String [Int]) <> Valid [2] `shouldBe` vi + + it "If applied to a valid and invalid proof, it results in the invalid proof." $ do + let + vi = Invalid ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + Valid [2] <> vi `shouldBe` (vi :: Proof String [Int]) + + it "If applied to two invalid proofs, it concatenates the errors." $ do + let + vi1 = Invalid ["Failure 1"] + (fromList [([mkName "Field1"], ["Field Failure 1"])]) + vi2 = Invalid ["Failure 2"] + (fromList [([mkName "Field1"], ["Field Failure 1.1"]), ([mkName "Field2"], ["Field Failure 2"])]) + vi3 = Invalid ["Failure 1", "Failure 2"] + (fromList [([mkName "Field1"], ["Field Failure 1", "Field Failure 1.1"]), ([mkName "Field2"], ["Field Failure 2"])]) + (vi1 :: Proof String [Int]) <> vi2 `shouldBe` vi3 + + describe "Functor (Proof f)" $ do + it "Converts a `Proof f a` to a `Proof f b`." $ do + fmap show (Valid 1 :: Proof String Int) `shouldBe` Valid "1" + + it "Does not change the contents of an invalid proof." $ do + let vi = Invalid ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + fmap show (vi :: Proof String Int) `shouldBe` (vi :: Proof String String) + + describe "Applicative (Proof f)" $ do + let + vap = Valid show :: Proof String (Int -> String) + iap = Invalid ["Applicative Failure"] mempty + vp = Valid 1 :: Proof String Int + ip = Invalid ["Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + + it "Constructs a new Valid proof" $ do + pure 1 `shouldBe` (Valid 1 :: Proof String Int) + + it "If applied to two invalid proofs, it concatenates the errors." $ do + (iap :: Proof String (Int -> String)) <*> ip + `shouldBe` Invalid ["Applicative Failure", "Failure"] (fromList [([mkName "Field1"], ["Field Failure"])]) + + it "If applied to an invalid and valid proof, it results in the invalid proof." $ do + (iap :: Proof String (Int -> String)) <*> vp + `shouldBe` (iap :: Proof String String) + + it "If applied to a valid and invalid proof, it results in the invalid proof." $ do + vap <*> (ip :: Proof String Int) `shouldBe` (ip :: Proof String String) + + it "If applied to two valid proofs, it should transform the second proof." $ do + vap <*> vp `shouldBe` Valid "1" + + describe "Monad (Proof f)" $ do + it "Binds a valid proof to a function." $ do + ((Valid 1 :: Proof String Int) >>= pure . show) `shouldBe` Valid "1" + + it "Does not change the contents of an invalid proof." $ do + ((Invalid ["Failure"] mempty :: Proof String Int) >>= pure . show) `shouldBe` Invalid ["Failure"] mempty + + describe "fromVCtx" $ do + let one = 1 :: Int + + it "Transforms a valid context to a valid proof." $ do + fromVCtx (ValidCtx one :: VCtx String Int) `shouldBe` Valid one + it "Transforms a disputed context to an invalid proof." $ do + let + v1 = DisputedCtx ["Failure"] (fromList [([mkName "Field1"],["Field Failure 1"])]) one + v2 = Invalid ["Failure"] (fromList [([mkName "Field1"],["Field Failure 1"])]) + fromVCtx v1 `shouldBe` v2 + it "Transforms a refuted context to an invalid proof." $ do + let + v1 = RefutedCtx ["Failure"] (fromList [([mkName "Field1"],["Field Failure 1"])]) + v2 = Invalid ["Failure"] (fromList [([mkName "Field1"],["Field Failure 1"])]) + fromVCtx (v1 :: VCtx String Int) `shouldBe` v2 + + describe "Functor ValueCtx" $ do + it "transforms a global context." $ do + fmap show (Global 1 :: ValueCtx Int) `shouldBe` Global "1" + + it "transforms a field context while preserving the field name." $ do + fmap show (Field (mkName "Field1") 1 :: ValueCtx Int) `shouldBe` Field (mkName "Field1") "1" + + describe "getValue" $ do + it "Retrieves the value from a global context." $ do + getValue (Global "1") `shouldBe` "1" + + it "Retrieves the value from a field context." $ do + getValue (Field (mkName "Field1") "1") `shouldBe` "1" + + describe "setValue" $ do + it "Creates a global context based on the given context." $ do + setValue (Global "1") (1 :: Int) `shouldBe` Global 1 + + it "Retrieves the value from a field context." $ do + setValue (Field (mkName "Field1") "1") (1 :: Int) `shouldBe` (Field (mkName "Field1") 1) + + describe "isRequired" $ do + it "Adds a failure to the context if the value is Nothing." $ do + let + v = Global (Nothing :: Maybe Bool) + r = isRequired "Failed" v + r `shouldBe` refute v "Failed" + + it "Should add no failure if the value is Just." $ do + let + v = Global $ Just True + v2 = Global True + r = isRequired "Failed" v + r `shouldBe` pure v2 + + describe "isLeft" $ do + it "Adds a failure to the context if the value is Right." $ do + let + v = Global (Right True :: Either Bool Bool) + r = isLeft "Failed" v + r `shouldBe` refute v "Failed" + + it "Should add no failure if the value is Left." $ do + let + v = Global $ (Left True :: Either Bool Bool) + v2 = Global True + r = isLeft "Failed" v + r `shouldBe` pure v2 + + describe "isRight" $ do + it "Adds a failure to the context if the value is Left." $ do + let + v = Global (Left True :: Either Bool Bool) + r = isRight "Failed" v + r `shouldBe` refute v "Failed" + + it "Should add no failure if the value is Right." $ do + let + v = Global $ (Right True :: Either Bool Bool) + v2 = Global True + r = isRight "Failed" v + r `shouldBe` pure v2 + + describe "isNull" $ do + it "Adds a failure to the context if the value is not null." $ do + let + v = Global "not null" + r = isNull "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value is null." $ do + let + v = Global "" + r = isNull "Failed" v + r `shouldBe` pure v + + describe "isNotNull" $ do + it "Adds a failure to the context if the value is null." $ do + let + v = Global "" + r = isNotNull "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value is not null." $ do + let + v = Global "not null" + r = isNotNull "Failed" v + r `shouldBe` pure v + + describe "minLength" $ do + it "Adds a failure to the context if the value has a length less than the given value." $ do + let + v = Global "TW" + r = minLength 3 "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value has a length equal to the given value." $ do + let + v = Global "THR" + r = minLength 3 "Failed" v + r `shouldBe` pure v + + it "Should add no failure if the value has a length greater than the given value." $ do + let + v = Global "THREE" + r = minLength 3 "Failed" v + r `shouldBe` pure v + + describe "maxLength" $ do + it "Adds a failure to the context if the value has a length greater than the given value." $ do + let + v = Global "FOUR" + r = maxLength 3 "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value has a length equal to the given value." $ do + let + v = Global "THR" + r = maxLength 3 "Failed" v + r `shouldBe` pure v + + it "Should add no failure if the value has a length less than the given value." $ do + let + v = Global "TW" + r = maxLength 3 "Failed" v + r `shouldBe` pure v + + describe "isLength" $ do + it "Adds a failure to the context if the value has a length greater than the given value." $ do + let + v = Global "FOUR" + r = isLength 3 "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value has a length equal to the given value." $ do + let + v = Global "THR" + r = isLength 3 "Failed" v + r `shouldBe` pure v + + it "Adds a failure to the context if the value has a length less than the given value." $ do + let + v = Global "TW" + r = isLength 3 "Failed" v + r `shouldBe` dispute v "Failed" + + describe "isEqual" $ do + it "Adds a failure to the context if the value is not equal to the given value." $ do + let + v = Global "1" + r = isEqual "2" "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value is equal to the given value." $ do + let + v = Global "1" + r = isEqual "1" "Failed" v + r `shouldBe` pure v + + describe "isNotEqual" $ do + it "Adds a failure to the context if the value is equal to the given value." $ do + let + v = Global "1" + r = isNotEqual "1" "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value is not equal to the given value." $ do + let + v = Global "1" + r = isNotEqual "2" "Failed" v + r `shouldBe` pure v + + describe "isLessThan" $ do + let + one = 1 :: Int + two = 2 :: Int + three = 3 :: Int + + it "Adds a failure to the context if the value is greater than the given value." $ do + let + v = Global three + r = isLessThan two "Failed" v + r `shouldBe` dispute v "Failed" + + it "Adds a failure to the context if the value is equal to the given value." $ do + let + v = Global two + r = isLessThan two "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value is less than the given value." $ do + let + v = Global one + r = isLessThan two "Failed" v + r `shouldBe` pure v + + describe "isLessThanOrEqual" $ do + let + one = 1 :: Int + two = 2 :: Int + three = 3 :: Int + + it "Adds a failure to the context if the value is greater than the given value." $ do + let + v = Global three + r = isLessThanOrEqual two "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value is equal to the given value." $ do + let + v = Global two + r = isLessThanOrEqual two "Failed" v + r `shouldBe` pure v + + it "Should add no failure if the value is less than the given value." $ do + let + v = Global one + r = isLessThanOrEqual two "Failed" v + r `shouldBe` pure v + + describe "isGreaterThan" $ do + let + one = 1 :: Int + two = 2 :: Int + three = 3 :: Int + + it "Should add no failure if the value is greater than the given value." $ do + let + v = Global three + r = isGreaterThan two "Failed" v + r `shouldBe` pure v + + it "Adds a failure to the context if the value is equal to the given value." $ do + let + v = Global two + r = isGreaterThan two "Failed" v + r `shouldBe` dispute v "Failed" + + it "Adds a failure to the context if the value is less than the given value." $ do + let + v = Global one + r = isGreaterThan two "Failed" v + r `shouldBe` dispute v "Failed" + + describe "isGreaterThanOrEqual" $ do + let + one = 1 :: Int + two = 2 :: Int + three = 3 :: Int + + it "Should add no failure if the value is greater than the given value." $ do + let + v = Global three + r = isGreaterThanOrEqual two "Failed" v + r `shouldBe` pure v + + it "Should add no failure if the value is equal to the given value." $ do + let + v = Global two + r = isGreaterThanOrEqual two "Failed" v + r `shouldBe` pure v + + it "Adds a failure to the context if the value is less than the given value." $ do + let + v = Global one + r = isGreaterThanOrEqual two "Failed" v + r `shouldBe` dispute v "Failed" + + describe "hasElem" $ do + it "Should add no failure if the value contains the given element." $ do + let + v = Global "test@example.com" + r = hasElem '@' "Failed" v + r `shouldBe` pure v + + it "Adds a failure to the context if the value does not contain the given element." $ do + let + v = Global "test.example.com" + r = hasElem '@' "Failed" v + r `shouldBe` dispute v "Failed" + + describe "doesNotHaveElem" $ do + it "Adds a failure to the context if the value contains the given element." $ do + let + v = Global "test@example site.com" + r = doesNotHaveElem ' ' "Failed" v + r `shouldBe` dispute v "Failed" + + it "Should add no failure if the value does not contain the given element." $ do + let + v = Global "test@example-site.com" + r = doesNotHaveElem ' ' "Failed" v + r `shouldBe` pure v + + describe "ifAny" $ do + it "Adds a failure to the context if no element in the list passes the check." $ do + let + v = Global ["foo", "bar", "baz", "bat"] + r = ifAny (\e -> bool (Just (e ++ " does not equal buz")) Nothing $ e == "buz") v + r `shouldBe` disputeMany v ["foo does not equal buz","bar does not equal buz","baz does not equal buz","bat does not equal buz"] + + it "Should add no failure if any element in the list passed the check." $ do + let + v = Global ["foo", "bar", "baz", "bat"] + r = ifAny (\e -> bool (Just (e ++ " does not equal foo")) Nothing $ e == "foo") v + r `shouldBe` pure v + + describe "ifAll" $ do + it "Adds a failure to the context if any element in the list does not pass the check." $ do + let + v = Global ["foo", "bar", "baz", "bat"] + r = ifAll (\e -> bool (Just (e ++ " does not have an 'a'")) Nothing $ elem 'a' e) v + r `shouldBe` disputeMany v ["foo does not have an 'a'"] + + it "Should add no failure if every element in the list passed the check." $ do + let + v = Global ["bar", "baz", "bat"] + r = ifAll (\e -> bool (Just (e ++ " does not have an 'a'")) Nothing $ elem 'a' e) v + r `shouldBe` pure v + + describe "ifEach" $ do + it "Adds a failure to the context if any element in the list does not pass the check." $ do + let + v = Global ["1", "2", "3", "bat"] + r = ifEach (\e -> readEither e :: Either String Int) v + r `shouldBe` refute v "Prelude.read: no parse" + + it "Should add no failure if every element in the list passed the check." $ do + let + v = Global ["1", "2", "3"] + r = ifEach (\e -> readEither e :: Either String Int) v + v2 = Global [1, 2, 3] + r `shouldBe` pure v2 + + describe "ifEachProven" $ do + it "Adds a failure to the context if any element in the list does not pass the check." $ do + let + v = Global ["1234567", "7654321", "5555555", "bat"] + r = ifEachProven mkPhoneNumber v + r `shouldBe` refute v "Phone number is the wrong length." + + it "Should add no failure if every element in the list passed the check." $ do + let + v = Global ["1234567", "7654321", "5555555"] + r = ifEachProven mkPhoneNumber v + v2 = Global [PhoneNumber "1234567", PhoneNumber "7654321", PhoneNumber "5555555"] + r `shouldBe` pure v2 + + describe "isMatch" $ do + it "Adds a failure to the context if value does not match the given value." $ do + let + v = Global "asdf" + vm = pure "fdsa" + r = isMatch "Failure" vm v + r `shouldBe` dispute v "Failure" + + it "Should add no failure if the value matches the given value." $ do + let + v = Global "asdf" + vm = pure "asdf" + r = isMatch "Failure" vm v + r `shouldBe` pure v + + describe "validateField" $ do + it "Uses the `Validatable` instance on a subfield for validation." $ do + let + c = Field (mkName "contact") (ContactVM "") + fromVCtx (validateField c) `shouldBe` Invalid [] (fromList [ + ([(mkName "contact"), 'phoneNumber], ["Phone Number cannot be empty."]) + ]) + +data Contact + = Contact + { validPhoneNumber :: String + } deriving (Show, Eq) + +data ContactVM + = ContactVM + { phoneNumber :: String + } deriving (Show, Eq) + +newtype PhoneNumber = PhoneNumber { unPhoneNumber :: String } + deriving (Show, Eq) +mkPhoneNumber :: String -> Proof String PhoneNumber +mkPhoneNumber s = fromVCtx $ do + v <- withValue s (isLength 7 "Phone number is the wrong length.") + return $ PhoneNumber v + +instance Validatable String ContactVM Contact where + validation c = + let + vp = withField 'phoneNumber (phoneNumber c) $ \v -> + isNotNull "Phone Number cannot be empty." v + in pure Contact <*> vp
+ test/Spec.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +-- **DO NOT ADD CODE TO THIS FILE** + +-- The tests are using HSpec's auto discovery feature. +-- To Add a spec, just create a file with the same directory structure as the project. +-- The file name must end with Spec.hs. +-- The module must export a function called 'spec' with a return type of Spec. +-- https://hspec.github.io/hspec-discover.html