diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for contracheck-applicative +## 0.2.0 Major update + * Add `CheckPatch`-module and functionality + * Add SOP-support + * Deprecate Control.Validation.Class + * Update documentation + +## 0.1.3 Update documentation + ## 0.1.1.1 Update documentation ## 0.1.1.0 Drop Checkable instances for Text and ByteString diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,49 +1,141 @@ contracheck-applicative ======================= + This package provides some simple yet useful types and functions to dynamically check properties of your data. # Table of contents 1. [Why use this library](#why) 2. [Quickstart](#quickstart) +3. [Documentation](#documentation) 1. [Types](#Types) * [`Unvalidated`](#Unvalidated) * [`CheckResult`](#CheckResult) * [`Check`](#Check) 2. [Composition of `Check`'s](#composition) - 3. [Combination of `Check`'s](#combination) - 4. [Dealing with additional context](#context) - 5. [`Checkable` Typeclass](#typeclass) + 1. [Pulling back `Check`s](#pullback) + 2. [Checking ADTs](#adt) + 3. [Combination of `Check`'s: Checking multiple things](#combination) + 3. [Dealing with additional context](#context) + 4. [`CheckPatch`: Fix your errors](#checkPatch) + 5. [`Checkable` Typeclass](#typeclass) # Why use this library? Runtime-checking for properties of data is the poor man's parsing. Nonetheless, sometimes it has do be done, and most of the time is not really pretty. -Most validation libraries define validations to be a type like `a -> Either Text a`, which makes sense as it captures the essence of validations: Put something in, and you either get it back and know your data is alright, or you have an error to work with. But the type `a -> Either Text a` does not behave nicely: +Most validation libraries define validations to be a type like `a -> Either Text a`, which makes sense as it captures the essence of what you do when you validate input: Put something in, and you either get it back and know your data is alright, or if it is not then you have an error to return. But the type `a -> Either Text a` does not behave nicely: * On the type level it does not distinguish between unvalidated and validated values. * Validations are not combinable: There is no canonical monoid instance * Validations are not reusable: It is invariant; so it is neither co- nor contravariant. -* Validations are not composable: There is no canonical way to combine a pair of validations `(a -> Either Text a, b -> Either Text b)` to a validation `(a, b) -> Either Text (a, b)` +* Validations are not composable: There is no canonical way to e.g. combine a pair of validations `(a -> Either Text a, b -> Either Text b)` to a validation `(a, b) -> Either Text (a, b)` -This library attempts to fix these issues. +This library attempts to make it pleasant to validate and more. # Quickstart +You validate your `Unvalidated` data by a (possibly very large `Check`); Either your data passed all the checks or you get a `Data.Sequence.Seq` of errors of type `e`: +```haskell +validateBy' :: Check' e a -> Unvalidated a -> Either (Seq e) a +validateBy :: Functor f => Check e f a -> Unvalidated a -> f (Either (Seq e) a) +``` +Depending on whether you need additional context `f` (such as `IO`) you should use the types functions postfixed by an apostrophe `'` (otherwise the context is `Identity`). -A `Check` is a function that takes an `Unvalidated` value and returns the result, possibly with a context: If the input has `Passed` the check or `Failed` it with a number of possible errors. +To use this library you want to +1. Wrap your unvalidated data in `Unvalidated` by either using `unvalidated :: a -> Unvalidated a` or via an orphan instance if you are brave enough (see below). +2. Write your basic `Check`s by + - `checking' :: (a -> CheckResult e) -> Check' e a ` + - or based on a predicate using the functions from the family `test`/`?>` +3. Combine them using + - `(<>) :: Check' e a -> Check' e a -> Check' e a` (Check both) + - `contramap :: (b -> a) -> Check' e a -> Check' e b` ("Pull back" a `Check` on an `a` to a Check on a `b` via a function `b -> a`) + - `joinMultiCheck` to easily compose a check for an ADT from checks for the single fields + - `choose / divide` to multiple single `Check`s to a `Check` on a sum / product if you need more flexibility +4. Run the checks via `validateBy' :: Check' e a -> Unvalidated a -> Either (Seq e) a`. +5. Check out `CheckPatch`es to maybe even preprocess your data before your business logic! + ```haskell -newtype Unvalidated a = Unvalidated { unsafeValidate :: a } -data CheckResult - = Passed - | Failed (Seq a) - -newtype Check e m a = Check { runCheck :: Unvalidated a -> m (CheckResult e) } -type Check' e = Check e Identity +type Name = String +type Age = Int + +data Pet = Dog Name Age | Cat Name + deriving (Show) + +data Profile = Profile + { _name :: Name + , _age :: Int + , _pet :: Pet + , _otherWebsites :: [String] + } deriving (Show) + + +checkNotEmpty = not . null ?>> "No name given" + +checkAdult = (>= 18) ?> printf "%s is too young; must be at least 18 years old" . show + +checkHttps = ("https://" `isPrefixOf`) ?> printf "Website '%s' is not secure: Missing 'https'" + +-- to do this we need +deriveGeneric ''Pet +checkPet = joinMultiCheck + ( (checkNotEmpty :* mempty :* Nil) + :* (checkNotEmpty :* Nil) + :* Nil ) + +checkProfile :: Check' Err Profile +checkProfile + = contramap _name checkNotEmpty + <> contramap _age checkAdult + <> contramap _pet checkPet + <> contramap _otherWebsites (foldWithCheck checkHttps) -- `foldWithCheck lifts a Check to a foldable, in this case a list` + +-- or again using generics: +deriveGeneric ''Profile +checkProfile2 :: Check' Err Profile +checkProfile2 = joinMultiCheck $ + ( checkNotEmpty + :* checkAdult + :* checkPet + :* foldWithCheck checkHttps + :* Nil ) :* Nil + +unvalidatedProfile1 = unvalidated $ + Profile "Fabian" 23 ["https://facebook.com/fabian"] + +unvalidatedProfile2 = unvalidated $ + Profile "" 23 ["http://fakebok.com/eviluser"] + +validateBy' checkProfile unvalidatedProfile1 +-- ~> Right (Profile "Fabian" ...) + +validateBy' checkProfile unvalidatedProfile2 +-- -> Left (fromList ["No name given", "Website 'https://...' is not secure"]) ``` +# Documentation + +Let's introduce these types to work with; the `deriveGeneric` is only used for `CheckPatch`es, so you can safely ignore it until you use that + +``` haskell +type Name = String +type Age = Int +type Err = String + +data Pet = Dog Name Age | Cat Name + deriving (Show) +deriveGeneric ''Pet + +data Profile = Profile + { _name :: Name + , _age :: Int + , _pet :: Pet + , _otherWebsites :: [String] + } deriving (Show) +deriveGeneric ''Profile +``` + ## Types -Basically all this library does is provide convenient instances for the following types. ### `Unvalidated` @@ -51,7 +143,7 @@ newtype Unvalidated a = Unvalidated { unsafeValidate :: a } ``` -The `Unvalidated` newtype is to make a distinction between validated and unvalidated values on the type level. It is often convient to give an orphan instance for the typeclass of your choice via `-XStandaloneDeriving` so unvalidated data cannot sneak into your system, e.g. +The `Unvalidated` newtype is to make a distinction between validated and unvalidated values on the type level. It is often convient to give an orphan instance for the typeclass of your choice via `-XStandaloneDeriving` so unvalidated data cannot sneak into your system, so in YOUR code you could for example declare (if your api has to deal with data incoming as JSON): ```haskell {-# language StandaloneDeriving, GeneralizedNewtypeDeriving, DerivingStrategies #-} import Data.Aeson(FromJSON) @@ -60,15 +152,16 @@ ### `CheckResult` ```haskell -data CheckResult +data CheckResult e = Passed - | Failed (Seq a) + | Failed (Seq e) + instance Monoid CheckResult instance Functor CheckResult ``` -It has a monoid instance that collects all possible errors, that is, it is not lazy in its failure component. +The type `CheckResult a` is basically `Either e ()` with a monoid instance that collects all possible errors. ### Check @@ -77,25 +170,31 @@ type Check' e = Check e Identity ``` -To start off lets give some simple examples. We construct `Check`s using the auxiliary combinators +A `Check` is a function that takes some `Unvalidated` data and produces a `CheckResult`. +Let's give some simple examples. We construct `Check`s using the auxiliary combinators +- For `CheckResult`s: * `failsWith :: e -> CheckResult e` + (`failsWith` is simply the constructor `Failed` precomposed with `Data.Sequence.Singleton`) * `failsNoMsg :: CheckResult e` + (`failsNoMsg = Failed mempty`) + +- For `Check`s (note the apostrophe at the end to indicate a "pure" Check, if you need monadic context such as `IO` use `checking` and `test`) * `checking' :: (a -> CheckResult e) -> Check' e a` * `test' :: Applicative m => (a -> Bool) -> (a -> e) -> Check e m a` + +Usage (academic examples): ```haskell import Data.Char(isAlpha) -checkEven :: Check' String Int +checkEven :: Check' Err Int checkEven = test ((== 0) . (`mod` 2)) (mappend "Number not even: " . show) -type Age = Int checkAge = test' (< 18) failsNoMsg -type Name = String -checkName = test $ \name -> +checkName = checking' $ \name -> let invalidChars = filter (not . isAlpha) name in if null invalidChars then Passed @@ -107,45 +206,104 @@ ## Composition of `Check`s - -The `Check` type is contravariant in the parameter to be checked (in fact, the whole library is merely a big wrapper around the instances for the type classes from the package [contravariant](https://www.stackage.org/package/contravariant)). This tells us that we can "pull back" checks to other types: +### Pulling back `Check`s +The `Check` type is contravariant in the parameter to be checked (in fact, the whole library is (edit: was, until the `CheckPatch` functionality was added) merely a big wrapper around the instances for the type classes from the package [contravariant](https://www.stackage.org/package/contravariant)). The `Contravariant`-instace allows us to "pull back" checks to other values: ```haskell -checkOdd = contramap (+1) checkEven +-- Given a Check for an Int we can pull it back to a Check for a String +-- by suppling a function `String -> Int` (`length` in this case): +checkEvenLength :: Check' Err String +checkEvenLength = contramap length checkEven ``` -So if we have a `Check` for an `a` and know how to convert a `b` into an `a` that preserves the property to be checked, we get a `Check` for our `b` for free. You can also pull back a pair of checks to a product/sum of types (`(,)/Either`) using `divide/choose` from the type classes `Divisible/Decidable` (also defined in the package [contravariant](https://www.stackage.org/package/contravariant)). We show how to use them by lifting a `Check` for an `a` to a `Check` for a list of `a`s: +So if we have a `Check` for an `a` and know how to convert a `b` into an `a` that preserves the property to be checked, we get a `Check` for our `b` for free. +### Checking ADTs +For ADTs the case is even simpler: For each constructor you give a list of `Check`s ─ one for each field ─ concatenated by `(:*)` and ended by `Nil`; so in total you have a nested list: A list of lists, one for each constructor, each containing the checks for the fields of that constructor, and then collapse it to a single 'Check' using 'joinMultiCheck': + +``` haskell +checkNotEmpty = not . null ?>> "No name given" + +checkAdult = (>= 18) ?> printf "%s is too young; must be at least 18 years old" . show + +checkHttps = ("https://" `isPrefixOf`) ?> printf "Website '%s' is not secure: Missing 'https'" + +checkPet :: Check' Err Pet +checkPet = joinMultiCheck + ( (checkNotEmpty :* mempty :* Nil) -- checks for the fields of the first constructor + :* (checkNotEmpty :* Nil) -- checks for the fields of the second constructor + :* Nil ) -- outer list is also terminated by `Nil` + +checkProfile :: Check' Err Profile +checkProfile = joinMultiCheck + ( checkNotEmpty + :* checkAdult + :* checkPet + :* foldWithCheck checkHttps -- `foldWithCheck` lifts a `Check` to a `Foldable`, in this case a list + :* Nil ) -- only one constructor, so the outer list is a singleton list + :* Nil +``` + +Unfortunately this way the information about which field of which constructor threw what error gets lost; the solution is `mapErrorsWithInfo`: It takes a function changing the error based on the datatype name, constructor name and field name. Make sure to apply it to the `MultiCheck`-list _BEFORE_ applying `joinMultiCheck`! + +``` haskell +addInfo :: DatatypeName -> ConstructorName -> FieldName -> (Err -> Err) +-- we are ignoring the constructorname as it is only one constructor anyway +addInfo d _ f err = printf "%s [Field %s]: %s" d f err + +checkProfile :: Check' Err Profile +checkProfile = joinMultiCheck . mapErrorsWithInfo addInfo $ + ( checkNotEmpty + :* checkAdult + :* checkPet + :* foldWithCheck checkHttps + :* Nil ) -- only one constructor, so the outer list is a singleton list + :* Nil + +-- $ validateBy' checkProfile (unvalidated $ Profile "" 23 (Cat "haskell") ["http://badsite.com"]) +-- >>> Left (fromList ["Profile: [Field _name]: No name given", "Profile: [Field _websites]: Website ... not secure ..."]) + +``` + +Another thing that is not optimal is if you have a lot of constructors but only want to check one, e.g. for +`data X = A | B | C | D | E | F | Other String`, the "MultiCheck"-list just gets very ugly. Fortunatley, theres a way around: `constructorCheck` takes the "index" of the constructor you want to check and just the list of 'Check's for this constructor; but careful, the index is counted in "unary" and is zero based: +* First constructor ~ `Z` +* Second constructor ~ `(S . Z)` +* Third constructor ~ `(S . S . Z)` +and so on. +A 'Check' for `X` above that only checks the `Other`-case for being not empty thus looks like + +``` haskell +checkOtherField = constructorCheck (S.S.S.S.S.S.Z) (checkNotEmpty :* Nil) +``` + + +If you need more granularity, you more generally can also pull back a pair of checks to an arbitrary (binary) product/sum of types (`(,)/Either`) using `divide/choose` from the type classes `Divisible/Decidable` (also defined in the package [contravariant](https://www.stackage.org/package/contravariant)). We show how to use them by lifting a `Check` for an `a` to a `Check` for a list of `a`s: + ```haskell checkListBy :: Check' e a -> Check' e [a] checkListBy checkA = choose split checkNil checkCons where - splitSum [] = Left () - splitSum (x:xs) = Right (x, xs) - checkNil = mempty + split [] = Left () + split (x:xs) = Right (x, xs) + checkNil = mempty -- mempty being the trivial check checkCons = divide id checkA (checkListBy checkA) ``` -To check a list `[a]` we have to distinguish two cases (`split`); either it is empty (`Left ()`), then we apply the trivial check `checkNil` or it is a cons, then we apply the check to the head and check the rest of the list. +To check a list `[a]` we have to distinguish two cases (`split`); either it is empty (`Left ()`), then we apply the trivial check `checkNil` or it is a cons, then we apply the check to the head and then check the rest of the list. -To summarize, we can use (with Types specialized to `Check`): -* `contramap` (≡ `>$<`): `(b -> a) -> Check e m a -> Check e m b` -* `divide :: (a -> (b, c)) -> Check e m b -> Check e m c -> Check e m a` -* `choose :: (a -> Either b c) -> Check e m b -> Check e m c -> Check e m a` -## Combination of `Check`'s +### Combination of `Check`'s: Checking multiple things -But now you want to combine your checks, e.g. to check a registration form. A first attempt might be to use the monoid instance of `CheckResult`. Note that it collects all errors and does not short-circuit if a `Check` fails (as you do not want to be _that_ guy that sends the registration form back twenty times with different errors). But fortunately the `Monoid`-instance of `CheckResult` lifts to `Checks`! That means we can use the `Semigroup/Monoid` operations on `Checks`, (`mempty` being the trivial `Check` that always succeeds). +If you want to combine multiple 'Check's of the same type to a larger 'Check', just use the Semigroup / Monoid instance for 'Check'. Note that it collects all errors and does not short-circuit if a `Check` fails (as you do not want to be _that_ guy that sends the registration form back twenty times with different errors). The neutral element `mempty` is the trivial `Check` that always succeeds. ```haskell -data Registration = Registration - { registrationAge :: Age - , registrationName :: Name - , registrationEmail :: String - } -checkRegistration - = contramap registrationAge checkAge - <> contramap registrationName checkName - <> contramap registrationEmail mempty -- of course unneccessary as it does nothing, but here for completeness +import Text.Printf(printf) +-- Here we use the combinaters to construct checks, if thats not your style use the 'test*' family. The precedence is so that it "just works" +checkNameInput :: Check' Err String +checkNameInput + = checkNotEmpty + <> (< 100) . length ?> printf "Input exeeds limit 100: %d" . length + <> not . (';' `elem`) ?>> "Bad input char: ';'" ``` ## Dealing with additional Context @@ -185,7 +343,7 @@ traverseWithCheck :: (Traversable t, Applicative m) => Check e m a -> Check e m (t a) ```haskell -type UrlList = [ Url ] +type UrlList = [Url] checkUrlList :: Check Status IO [Url] checkUrlList = traverseWithCheck checkUrlNo4xx ``` @@ -212,12 +370,88 @@ ``` does *NOT* work as here you lift into the parallel context after all the checks have been performed. -Thats about it. +## `CheckPatch`: Fix the problems that occured while checking the data +A `CheckPatch e m a` is like a `Check e m a` but for each error that happens it may contain a "patch" to fix it. `Patch` tries to fix its input if it can +or else aborts, so it is defined simply as +``` haskell +newtype Patch a = Patch { runPatch :: a -> Maybe a } +``` +Note that when you combine `CheckPatch`es and one `CheckPatch` cannot patch its input (returns `Nothing`) then the whole `CheckPatch` returns `Nothing`. +`CheckPatch`es work mostly like `Check`s, the corresponding functions have a -`Patch` suffix (so `test` becomes `testPatch` etc.). To construct a `CheckPatch` you either lift an existing `Check` ─ with (`liftPatch`) or without (`liftNoPatch`) supplying a `Patch` ─ or by constructing them the same way as `Check`s: Via +`checkingPatch`, `testPatch` etc., the only difference is that you know need to say how you want to fix your data (or if it is "unfixable"). +Unfortunately, `contramap`, `divide` and `choose` are a little bit more complicated now: Instead of normal functions they take `Lens`es to split up or view inside the data. BUT the `MultiCheckPatch` works the same way as the normal `MultiCheck`. -## `Checkable` typeclass +The previous examples, but this time with `CheckPatch`. -There is also a typeclass in the module Control.Validation.Class, but it has to be used with care as it does not perform any Checks on primitive types and this is often not what you want. You should probably use it _only_ on nested structures made up solely from custom data types, and otherwise define the checks explicitly. +``` haskell +-- Checks whether the string is empty (then it has NO patch, so it aborts) +-- Or if it contains semicolons, then it filters them out. +checkNotEmptyAndNoSemicolonP :: Applicative m => CheckPatch [Char] m String +checkNotEmptyAndNoSemicolonP = liftNoPatch checkNotEmpty <> checkNoSemicolonP + where + checkNoSemicolonP = testPatch'_ + (not . elem ';') + "Input contains semicolon" + (patch $ filter (/= ';')) + +-- Being to young cannot be patched +checkAdultP :: Applicative m => CheckPatch [Char] m Int +checkAdultP = liftNoPatch $ checkAdult + + +checkPetP2 :: Applicative m => CheckPatch String m Pet +checkPetP2 = joinMultiCheckPatch + ( (checkNotEmptyAndNoSemicolonP :* mempty :* Nil) + :* (checkNotEmptyAndNoSemicolonP :* Nil) + :* Nil ) + + +checkProfileP2 :: CheckPatch String IO Profile +checkProfileP2 = constructorCheckPatch Z + ( checkNotEmptyAndNoSemicolonP + :* checkAdultP + :* checkPetP2 + :* liftNoPatch checkWebsites + :* Nil ) + + + + + +-- This is just to show how you would use `chooseL`; here you probably would use `joinMultiCheckPatch`, see above +-- +-- To check the 'Pet', we now need "splitting" 'Lens'es instead of simple functions. A 'Lens Pet (Either (Name, Age) Age)' unfortunately is not auto-derivable, +-- but we almost always can use the fact that this lens can (and mostly _should_ be) an isomorphism. +checkPetP :: Applicative m => CheckPatch [Char] m Pet +checkPetP = chooseL splitPetLens checkDog checkCat + where + splitPetLens :: Lens' Pet (Either (Name, Age) Name) -- forall f. Functor f => (Either (Name, Age) Age -> f (Either (Name Age), Age)) -> Pet -> f Pet + splitPetLens f = \case + Dog name age -> either (uncurry Dog) Cat <$> f (Left (name, age)) + Cat name -> either (uncurry Dog) Cat <$> f (Right name) + checkDog = divideL id checkNotEmptyAndNoSemicolonP mempty + checkCat = checkNotEmptyAndNoSemicolonP + + + +-- No we can wrap it up using our TemplateHaskell-derived 'Lens'es: Additionally, we throw out websites that are not https. +makeLenses ''Profile +checkProfileP :: CheckPatch String IO Profile +checkProfileP = contramapL name checkNotEmptyAndNoSemicolonP + <> contramapL age checkAdultP + <> contramapL pet checkPetP + <> contramapL otherWebsites (liftNoPatch checkWebsites) + + + + + +``` + +## `Checkable` typeclass + +The typeclass is deprecated as its use was very limited and is basically redundant with the new SOP-functions. diff --git a/contracheck-applicative.cabal b/contracheck-applicative.cabal --- a/contracheck-applicative.cabal +++ b/contracheck-applicative.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack -- --- hash: 51671db44a11779c126bbc3f411fe9d3906c8c1e0eb1b59647fd4c8b0bf139f0 +-- hash: c7e6a1f49a69a3f1becfa1d9f88b73051569150cd03580d7c4451f9e8303f73a name: contracheck-applicative -version: 0.1.2 +version: 0.2.0 synopsis: Validation types/typeclass based on the contravariance. description: This package provides types and a typeclass that allow for effectful validation and easy composition. For documentation see the [README](https://gitlab.com/Birkmann/validation-check/-/blob/master/README.md). If there are any issues, contact me at 99fabianb@sis.gl or add an issue on [gitlab](https://gitlab.com/Birkmann/validation-check). category: Validation @@ -25,6 +25,8 @@ exposed-modules: Control.Validation.Check Control.Validation.Class + Control.Validation.Internal.SOP + Control.Validation.Patch other-modules: Paths_contracheck_applicative hs-source-dirs: @@ -32,7 +34,9 @@ ghc-options: -Wall -Wcompat -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields build-depends: base >=4.7 && <5 - , containers >=0.4 && <0.7 + , containers >=0.2 && <0.7 , contravariant >=1.0.0 && <1.6 - , mmorph >=1.0.0 && <1.2 + , generics-sop >=0.4.0.0 && <0.6 + , microlens >=0.1.3 && <0.5 + , mmorph >=1.1.0 && <1.2 default-language: Haskell2010 diff --git a/src/Control/Validation/Check.hs b/src/Control/Validation/Check.hs --- a/src/Control/Validation/Check.hs +++ b/src/Control/Validation/Check.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} {-| Module : Validation Description : Validation types/typeclass that allow for effectful validation and easy composition. @@ -7,12 +11,18 @@ Stability : experimental Portability : POSIX -Types and functions to check properties of your data. To make best use of these functions you should check out "Data.Functor.Contravariant". For documentation see the (README)[https://gitlab.com/Birkmann/validation-check/-/blob/master/README.md]. +Types and functions to check properties of your data. To make best use of these functions you should check out "Data.Functor.Contravariant". For an introduction see the [README](https://gitlab.com/Birkmann/validation-check/-/blob/master/README.md). -} -{-# LANGUAGE - PolyKinds, TypeOperators, LambdaCase, - DerivingStrategies, DerivingVia, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveGeneric - #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} + +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} module Control.Validation.Check( -- * Unvalidated values -- $unvalidated @@ -24,67 +34,88 @@ -- ** Check results -- $checkResults - -- + -- CheckResult(..), checkResult, failsWith, failsNoMsg, passed, failed, checkResultToEither, -- ** The Check type -- $check -- - Check(..), Check', + Check(..), Check', pass, passOnRight, mapError, generalizeCheck, validateBy, validateBy', -- *** Constructing checks - -- $constructingChecks - -- + -- $constructingChecks checking, checking', + -- $constructionByPredicate test, (?~>), - test', (?>), - test_, (?~>>), + test', (?>), + test_, (?~>>), test'_,(?>>), - -- ** Helper for deriving Checkable + -- ** Lifting Checks -- $derivHelper - foldWithCheck, traverseWithCheck, + foldWithCheck, traverseWithCheck, + -- ** For ADTs + -- $adts + joinMultiCheck, mapErrorsWithInfo, constructorCheck, + -- * Reexports - hoist, contramap -) where + -- ** General + hoist, contramap, -import Data.Kind (Type) -import GHC.Generics (Generic) + -- ** SOP + NP(..), DatatypeName, ConstructorName, FieldName +) -import Control.Monad.Morph (MFunctor(..)) -import Data.Functor ((<&>)) -import Data.Functor.Contravariant (Contravariant(..), Op(..)) -import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..)) -import Data.Functor.Identity (Identity(..)) +where -import Data.Foldable (fold) -import Data.Monoid (Ap(..)) +import Data.Kind (Type) +import Control.Validation.Internal.SOP(errMsgPOP) +import GHC.Generics as GHC(Generic) +import Generics.SOP as SOP(POP(..), unPOP, mapIK, hliftA2, unK, hcfoldMap, NP(..), Generic(..), Top, HasDatatypeInfo(..), DatatypeName, ConstructorName, FieldName, NS(..), SListI, hcexpand, hpure) +import Data.Proxy(Proxy(..)) +import Control.Monad.Morph (MFunctor (..)) +import Data.Functor ((<&>)) +import Data.Functor.Contravariant (Contravariant (..), + Op (..)) +import Data.Functor.Contravariant.Divisible (Decidable (..), + Divisible (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Foldable (fold) +import Data.Monoid (Ap (..)) -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq(singleton) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq (singleton) + ---------------------------------------------------------------------------------- -- = 'Unvalidated' -- $unvalidated --- A newtype around unvalidated values so one cannot use the value until it is validated. --- You can create an 'Unvalidated' via 'unvalidated', but it is often more convient --- If for example you have a JSON api and want to validate incoming data, you can --- write (using `-XStandaloneDeriving, -XDerivingStrategies, -XDerivingVia`): +-- A newtype around unvalidated values so one cannot use the value until it is validated. +-- You can create an 'Unvalidated' via 'unvalidated' -- +-- __/WARNING/__ The 'Unvalidated' data construcotr should __/NOT/__ be used in real code and is exported solely to be used in @-XDeriving@-clauses +-- +-- , but it is often more convient to write an orphan instance: +-- If for example you have a JSON api and want to validate incoming data, you can +-- write (using @-XStandaloneDeriving, -XDerivingStrategies, -XDerivingVia@): +-- -- > import Data.Aeson(FromJSON) -- > deriving via (a :: Type) instance (FromJSON a) => FromJSON (Unvalidated a) -newtype Unvalidated (a :: Type) = - Unvalidated { unsafeValidate :: a } - deriving (Eq, Ord, Show, Functor, Generic) +newtype Unvalidated (a :: Type) = + MkUnvalidated { unsafeValidate :: a } + deriving (Eq, Ord, Show, Functor, GHC.Generic) + deriving (Applicative, Monad) via Identity +{-# WARNING MkUnvalidated "Use 'unvalidated'. The data constructor 'Unvalidated' is not to be used in code and is only exported for use in deriving clauses" #-} + {-# INLINE unvalidated #-} unvalidated :: a -> Unvalidated a -unvalidated = Unvalidated +unvalidated = MkUnvalidated @@ -95,14 +126,14 @@ -- == Check results -- $checkResults --- The result of (possibly many) checks. It is either valid or a sequence of +-- The result of (possibly many) checks. It is either valid or a sequence of -- all the errors that occurred during the check. -- The semigroup operation is eager to collect all possible erros. data CheckResult (e :: Type) = Passed - | Failed (Seq e) - deriving (Show, Eq, Generic, Functor) + | Failed !(Seq e) + deriving (Show, Eq, GHC.Generic, Functor) instance Semigroup (CheckResult e) where Passed <> x = x @@ -112,6 +143,8 @@ instance Monoid (CheckResult e) where mempty = Passed + + failsWith :: e -> CheckResult e failsWith = Failed . Seq.singleton @@ -121,7 +154,7 @@ -- | A fold for 'CheckResult' checkResult :: a -> (Seq e -> a) -> CheckResult e -> a -checkResult x _ Passed = x +checkResult x _ Passed = x checkResult _ f (Failed e) = f e passed, failed :: CheckResult e -> Bool @@ -140,16 +173,16 @@ ---------------------------------------------------------------------------------- -- ** The Check type -- $check --- The type of a (lifted) check. A 'Check' takes an unvalidated data and produces +-- The type of a (lifted) check. A 'Check' takes an unvalidated data and produces -- a 'CheckResult'. It may need an additional context `m`. If the context is trivial --- (`m ≡ Identity`) helper types/functions are prefixed by a `'`. --- A 'Check' is not a validation function, as it does not produce any values --- (to validated data using a 'Check' use 'validateBy'). The reason for this is that --- it gives 'Check' some useful instances, as it now is contravariant in `a` +-- ('m ≡ Identity') helper types/functions are postfixed by an apostrophe `'`. +-- A 'Check' is not a validation function, as it does not produce any values +-- (to validated data using a 'Check' use 'validateBy'). The reason for this is that +-- it gives 'Check' some useful instances, as it now is contravariant in `a` -- and not invariant in `a` like e.g. `a -> Either b a` -- -- * Contravariant --- +-- -- > newtype Even = Even { getEven :: Int } -- > checkEven :: Check' Text Even -- > checkEven = (== 0) . (`mod` 2) . getEven ?> mappend "Number is not even: " . show @@ -157,16 +190,16 @@ -- > newtype Odd = Odd { getOdd :: Int } -- > checkOdd :: Check' Text Odd -- > checkOdd = Even . (+1) . getOdd >$< checkEven --- +-- -- * Semigroup/Monoid: Allows for easy composition of checks --- +-- -- > newtype EvenAndOdd = EvenAndOdd { getEvenAndOdd :: Int } -- > checkevenAndOdd :: Check' Text EvenAndOdd -- > checkEvenAndOdd = contramap (Even . getEvenAndOdd) checkEven -- > <> contramap (Odd . getEvenAndOdd) checkOdd --- +-- -- * MFunctor: Changing the effect --- +-- -- > import Data.List(isPrefixOf) -- > newtype Url = Url { getUrl :: String } -- > @@ -180,7 +213,7 @@ -- -- For more information see the README. -newtype Check (e :: Type) (m :: Type -> Type) (a :: Type) +newtype Check (e :: Type) (m :: Type -> Type) (a :: Type) = Check { runCheck :: Unvalidated a -> m (CheckResult e) } deriving ( Monoid, Semigroup ) via (a -> Ap m (CheckResult e)) deriving ( Contravariant, Divisible, Decidable) via (Op (Ap m (CheckResult e))) @@ -188,15 +221,18 @@ instance MFunctor (Check e) where hoist f = withCheck (f .) -withCheck :: ( (Unvalidated a -> m (CheckResult d)) +withCheck :: ( (Unvalidated a -> m (CheckResult d)) -> Unvalidated b -> n (CheckResult e)) -> Check d m a -> Check e n b withCheck f = Check . f . runCheck +-- | The trivial 'Check' that always succeeds. +pass :: Applicative m => Check e m a +pass = mempty -- | Validate 'Unvalidated' data using a check. validateBy :: Functor m => Check e m a -> Unvalidated a -> m (Either (Seq e) a) -validateBy c u@(Unvalidated x) = fmap (checkResultToEither x) . runCheck c $ u +validateBy c u@(MkUnvalidated x) = fmap (checkResultToEither x) . runCheck c $ u -- | 'validateBy' for trivial context. validateBy' :: Check' e a -> Unvalidated a -> Either (Seq e) a @@ -209,12 +245,12 @@ generalizeCheck :: Applicative m => Check' e a -> Check e m a generalizeCheck = hoist (pure . runIdentity) --- | 'passOnRight `ignoreWhen` `check` lets the argument pass when --- `ignoreWhen` returns `Nothing` and otherwise checks +-- | 'passOnRight `ignoreWhen` `check` lets the argument pass when +-- `ignoreWhen` returns `Right ()` and otherwise checks -- with `check`. It is a special case of 'choose' from 'Decidable'. -- It gives an example for how 'Check's expand to other datatypes since they are -- 'Divisible' and 'Decidable', see generalizing a check to lists: --- +-- -- > checkList :: Applicative m => Check e m a -> Check e m [a] -- > checkList c = passOnRight (\case -- > [] -> Right () @@ -233,23 +269,26 @@ ------------------------------------------------------------------------------------------------------ -- === Construction of 'Check's -- $constructingChecks --- Constructing a check from a predicate. Naming conventions: +-- The general way to construct a 'Check': Take the data to be checked and return a 'CheckResult'. -- --- * Functions that work on trivial contexts are prefixed by an apostrophe `'`. +-- ==== Construction by predicates +-- $constructionByPredicate +-- Constructing a check from a predicate (if a prediceate returns 'True', the check passes) and a function constructing the error from the input. Naming conventions: +-- +-- * Functions that work on trivial contexts are postfixed by an apostrophe `'`. -- * Check constructors that discard the argument on error end with `_`. -- * All infix operators start with `?` and end with `>` (So `?>` is the "normal" version). -- * Additional >: discards its argument: `?>>`, `?~>>`. -- * Tilde works with non-trivial contexts: `?~>`, `?~>>`. --- | General construction function for checks. checking :: (a -> m (CheckResult e)) -> Check e m a -checking = Check . (. unsafeValidate) +checking = Check . (. unsafeValidate) checking' :: (a -> CheckResult e) -> Check' e a checking' = checking . (Identity .) -test', (?>) :: Applicative m => (a -> Bool) -> (a -> e) -> Check e m a -test' p onErr = Check $ \(Unvalidated x) -> pure $ if p x +test', (?>) :: Applicative m => (a -> Bool) -> (a -> e) -> Check e m a +test' p onErr = Check $ \(MkUnvalidated x) -> pure $ if p x then Passed else failsWith (onErr x) infix 7 `test'` @@ -258,19 +297,19 @@ infix 7 ?> --- +-- -- > test'_ p e = test' p onErr -- > where onErr = const e {-# INLINE test'_ #-} -test'_,(?>>) :: Applicative m => (a -> Bool) -> e -> Check e m a -test'_ p = test' p . const +test'_,(?>>) :: Applicative m => (a -> Bool) -> e -> Check e m a +test'_ p = test' p . const infix 7 `test'_` {-# INLINE (?>>) #-} (?>>) = test'_ infix 7 ?>> -test, (?~>) :: Functor m => (a -> m Bool) -> (a -> e) -> Check e m a -test p onErr = Check $ \(Unvalidated x) -> p x <&> \case +test, (?~>) :: Functor m => (a -> m Bool) -> (a -> e) -> Check e m a +test p onErr = Check $ \(MkUnvalidated x) -> p x <&> \case True -> Passed False -> failsWith . onErr $ x infix 7 `test` @@ -281,14 +320,14 @@ -- > test_ p e = test p onErr -- > where onErr = const e {-# INLINE test_ #-} -test_, (?~>>) :: Monad m => (a -> m Bool) -> e -> Check e m a -test_ p = test p . const +test_, (?~>>) :: Monad m => (a -> m Bool) -> e -> Check e m a +test_ p = test p . const infix 7 `test_` {-# INLINE (?~>>) #-} (?~>>) = test_ infix 7 ?~>> - + -- | Lift a check to a foldable foldWithCheck :: (Foldable f, Applicative m) => Check e m a -> Check e m (f a) foldWithCheck c = checking $ getAp . foldMap (Ap . runCheck c . unvalidated) @@ -297,6 +336,29 @@ traverseWithCheck :: (Traversable t, Applicative m) => Check e m a -> Check e m (t a) traverseWithCheck c = checking $ fmap fold . traverse (runCheck c . unvalidated) +-- == Lift 'Check's to ADTs +-- $adts +-- | A "Multi"-'Check' for an ADT, one 'Check e m' for each field of each constructor, organized in Lists (see examples for construction) +type MultiCheck e m a = NP (NP (Check e m)) (Code a) +-- | Combine all 'Check's from a 'MultiCheck' into a single 'Check' for the datatype 'a' (given it has a 'Generic' instance). +joinMultiCheck :: forall a m e. (Applicative m, SOP.Generic a) => MultiCheck e m a -> Check e m a +joinMultiCheck checks = checking $ getAp + . hcfoldMap (Proxy @Top) (Ap . unK) + . hliftA2 (\c -> mapIK $ runCheck c . unvalidated) + (POP $ checks) + . from + + +-- | Change the error of a 'MultiCheck' using the information about the datatype. +mapErrorsWithInfo :: forall e e' a m. (Functor m, HasDatatypeInfo a) => Proxy a -> (DatatypeName -> ConstructorName -> FieldName -> e -> e') -> MultiCheck e m a -> MultiCheck e' m a +mapErrorsWithInfo p f = unPOP . hliftA2 (mapError . unK) (errMsgPOP p f) . POP + +-- | Make a 'Check' for that only checks a single constructor by suppling a list containing a 'Check' for each field +constructorCheck :: forall a m e xs. (Applicative m, SOP.Generic a) + => (NP (Check e m) xs -> NS (NP (Check e m)) (Code a)) -- ^ The function deciding the constructor, 'Z' for the zeroth, 'S . Z' for the first, etc. + -> NP (Check e m) xs -- ^ Product of 'Checkes', one for each constructor + -> Check e m a +constructorCheck f ps = joinMultiCheck . hcexpand (Proxy @SListI) (hpure mempty) . f $ ps diff --git a/src/Control/Validation/Class.hs b/src/Control/Validation/Class.hs --- a/src/Control/Validation/Class.hs +++ b/src/Control/Validation/Class.hs @@ -1,47 +1,59 @@ -{-# LANGUAGE - LambdaCase, DerivingStrategies, DerivingVia, StandaloneDeriving, KindSignatures, GeneralizedNewtypeDeriving, - PolyKinds, TypeOperators, - DefaultSignatures, InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances - #-} -module Control.Validation.Class( +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Control.Validation.Class {-# DEPRECATED "This module is no longer supported." #-}( -- * Checkable -- $checkable validate, validate', CheckChain(..), overChain, (+?+), singleChain, - Validatable(..), + Validatable(..), TrivialCheck(..), -- ** Helper for deriving Validatable -- $derivHelper -- * Reexports - + ) where -import Data.Foldable(fold) -import Data.Kind(Type) -import Data.Void(Void) -import Data.Int(Int8, Int16, Int32, Int64) -import Control.Validation.Check -import Data.Functor.Identity(Identity(..)) -import Data.Sequence(Seq) -import GHC.Generics -import Data.Functor.Contravariant.Compose(ComposeFC(..)) -import Data.Functor.Contravariant(Contravariant(..)) -import Data.Functor.Contravariant.Divisible(Divisible(..), Decidable(..)) -import Control.Monad.Morph(MFunctor(..)) +import Control.Monad.Morph (MFunctor (..)) +import Control.Validation.Check +import Data.Foldable (fold) +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Functor.Contravariant.Compose (ComposeFC (..)) +import Data.Functor.Contravariant.Divisible (Decidable (..), + Divisible (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int16, Int32, Int64, + Int8) +import Data.Kind (Type) +import Data.Sequence (Seq) +import Data.Void (Void) +import GHC.Generics ------------------------------------------------------------------------------------------------------ -- $checkable --- = The 'Validatable' typeclass. +-- = The 'Validatable' typeclass. -- /Note/: It is not inteded to be used for testing of --- internal integrity of types, i.e. it does not check if a 'Text' has a valid internal +-- internal integrity of types, i.e. it does not check if a 'Text' has a valid internal -- representation. For testing internal integrity please use the package -- (validity)[https://stackage.org/package/validity]. --- The typeclass is split up into three parts: --- --- * 'checkChain': A list of checks that will be performed in +-- The typeclass is split up into three parts: +-- +-- * 'checkChain': A list of checks that will be performed in -- that order. This has to be provided to give an instance. --- For the reason why it is given as a list and the checks are +-- For the reason why it is given as a list and the checks are -- not combined via '(<>)', see the point for `isValid`. -- -- * 'defaulCheck': A check performing all checks of 'checkChain' @@ -55,27 +67,26 @@ -- goes through all operands, so `passed $ runCheck (shortCheck <> longCheck) unvalidatedInput` -- evalutes the argument with `longCheck` even if `shortCheck` failed. -- But if we define --- +-- -- > instance Validatable e m T where -- > checkChain = CheckChain [ shortCheck, longCheck ] --- +-- -- then `isValid unvalidatedInput` stops after `shortCheck` failed. - -newtype CheckChain (e :: Type) (m :: Type -> Type) (a :: Type) = +newtype CheckChain (e :: Type) (m :: Type -> Type) (a :: Type) = CheckChain { runCheckChain :: [ Check e m a ] } - deriving newtype ( Monoid, Semigroup ) + deriving newtype ( Monoid, Semigroup ) deriving (Contravariant, Divisible, Decidable) via (ComposeFC [] (Check e m)) instance MFunctor (CheckChain e) where hoist f = overChain (hoist f) overChain :: (Check e m a -> Check e' n b) -> CheckChain e m a -> CheckChain e' n b -overChain f = CheckChain . fmap f . runCheckChain +overChain f = CheckChain . fmap f . runCheckChain -- | Convenience synonym. {-# INLINE (+?+) #-} -(+?+) :: CheckChain e m a -> CheckChain e m a -> CheckChain e m a +(+?+) :: CheckChain e m a -> CheckChain e m a -> CheckChain e m a (+?+) = (<>) infixr 5 +?+ -- so it behaves like list concatenation @@ -89,22 +100,22 @@ -- | Constructs a chain with only one check. singleChain :: Check e m a -> CheckChain e m a singleChain x = CheckChain [ x ] - + -- | These are the functions used to validate data. Return either a validated result or a sequence of all validation errors that occured. {-# INLINABLE validate' #-} validate' :: Validatable e Identity a => Unvalidated a -> Either (Seq e) a -validate' u@(Unvalidated x) = - checkResultToEither x - . runIdentity - . runCheck defaultCheck +validate' u = + checkResultToEither (unsafeValidate u) + . runIdentity + . runCheck defaultCheck $ u {-# INLINABLE validate #-} validate :: (Validatable e m a, Functor m) => Unvalidated a -> m (Either (Seq e) a) -validate u@(Unvalidated x) = - fmap (checkResultToEither x) - . runCheck defaultCheck +validate u = + fmap (checkResultToEither $ unsafeValidate u) + . runCheck defaultCheck $ u @@ -122,22 +133,22 @@ isValid :: Unvalidated a -> m Bool default isValid :: Applicative m => Unvalidated a -> m Bool isValid u = fmap (all passed) $ traverse (($ u) . runCheck) $ runCheckChain checkChain - + deriving via TrivialCheck () instance Validatable Void Identity () -deriving via TrivialCheck Bool instance Validatable Void Identity Bool -deriving via TrivialCheck Char instance Validatable Void Identity Char -deriving via TrivialCheck Double instance Validatable Void Identity Double -deriving via TrivialCheck Float instance Validatable Void Identity Float -deriving via TrivialCheck Int instance Validatable Void Identity Int -deriving via TrivialCheck Int8 instance Validatable Void Identity Int8 -deriving via TrivialCheck Int16 instance Validatable Void Identity Int16 +deriving via TrivialCheck Bool instance Validatable Void Identity Bool +deriving via TrivialCheck Char instance Validatable Void Identity Char +deriving via TrivialCheck Double instance Validatable Void Identity Double +deriving via TrivialCheck Float instance Validatable Void Identity Float +deriving via TrivialCheck Int instance Validatable Void Identity Int +deriving via TrivialCheck Int8 instance Validatable Void Identity Int8 +deriving via TrivialCheck Int16 instance Validatable Void Identity Int16 deriving via TrivialCheck Int32 instance Validatable Void Identity Int32 deriving via TrivialCheck Int64 instance Validatable Void Identity Int64 deriving via TrivialCheck Integer instance Validatable Void Identity Integer - + instance (Validatable e m a, Applicative m) => (Validatable e m (Maybe a)) where checkChain = traverseWithCheck `overChain` checkChain @@ -152,12 +163,12 @@ -- $derivHelper -- == Helper for deriving Validatable -- Intended for use with `-XDerivingVia` like --- +-- -- > data X = X Int -- > deriving (Validatable Void Identity) via (TrivialCheck X) -- > -- or with `-XStandaloneDeriving` -- > data Y = Y String --- > deriving via (TrivialCheck Y) instance (Validatable Void Identity Y) +-- > deriving via (TrivialCheck Y) instance (Validatable Void Identity Y) newtype TrivialCheck a = TrivialCheck { unTrivialCheck :: a } diff --git a/src/Control/Validation/Internal/SOP.hs b/src/Control/Validation/Internal/SOP.hs new file mode 100644 --- /dev/null +++ b/src/Control/Validation/Internal/SOP.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +-- | This is an internal module and subject to change. Should not be used in production + +module Control.Validation.Internal.SOP where + +import Data.Proxy(Proxy(..)) +import Generics.SOP(constructorName, hpure, hmap, hcmap, constructorInfo, datatypeName, unI, ConstructorInfo(..), SListI, SListI2, NP, HasDatatypeInfo(..), ConstructorName, FieldName, POP(..), K(..), DatatypeName, Generic(..), FieldInfo(..), Rep, NS(..), I(..), NP(..)) + + +-- | Helper functions to supply the datatype-info +errMsgPOP :: forall e a e'. (HasDatatypeInfo a) => Proxy a -> (DatatypeName -> ConstructorName -> FieldName -> e -> e') -> POP (K (e -> e')) (Code a) +errMsgPOP p f = errMsgPOP' @e @a (f $ datatypeName inf) (constructorInfo inf :: NP ConstructorInfo (Code a)) + where inf = datatypeInfo p + +errMsgPOP' :: forall e a e'. (SListI2 (Code a)) => (ConstructorName -> FieldName -> e -> e') -> NP ConstructorInfo (Code a) -> POP (K (e -> e')) (Code a) +errMsgPOP' f cinfos = POP $ hcmap (Proxy @SListI) (errMsgNP f) cinfos +errMsgNP :: forall e xs e'. (SListI xs) => (ConstructorName -> FieldName -> e -> e') -> ConstructorInfo xs -> NP (K (e -> e')) xs +errMsgNP f = \case + Record name finfos -> hmap (\(FieldInfo fname) -> K $ f name fname) finfos + constr -> hpure $ (K $ f (constructorName constr) "" :: forall a. K (e -> e') a) + + + + + + +-- helper optics +type Optic f s a = (a -> f a) -> (s -> f s) +type T' s a = forall f. Applicative f => Optic f s a + +sopLensTo :: (Functor f, Generic a) => Optic f a (Rep a) +sopLensTo l = fmap to . l . from + +tZ :: T' (NS g (x ': xs)) (g x) +tZ f = \case + Z h -> Z <$> f h + S t -> pure (S t) + +tS :: T' (NS g (x ': xs)) (NS g xs) +tS f = \case + Z h -> pure (Z h) + S t -> S <$> f t + + +tI :: T' (I a) a +tI f = fmap I . f . unI + + +tH :: T' (NP g (x ': xs)) (g x) +tH f = \(x :* xs) -> (:* xs) <$> f x + +tT :: T' (NP g (x ': xs)) (NP g xs) +tT f = \(x :* xs) -> (x :*) <$> f xs diff --git a/src/Control/Validation/Patch.hs b/src/Control/Validation/Patch.hs new file mode 100644 --- /dev/null +++ b/src/Control/Validation/Patch.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Control.Validation.Patch( + +-- * Patch +-- $patch +Patch(..), patch, noPatch, +-- * CheckPatch +-- $checkPatch +CheckPatch(..), CheckPatch', runCheckPatch, runCheckPatch', +liftPatch, liftNoPatch, demotePatch, mapErrorPatch, overCheck, Patched(..), validateByPatch, validateByPatch', + +-- * Lens-variants of functions on 'Check's +-- $lens-variants +contramapL, chooseL, divideL, + +-- * Construction of 'CheckPatch'es +-- $construction + + checkingPatch, checkingPatch', + -- $constructionByPredicate + testPatch, + testPatch', + testPatch_, + testPatch'_, + testPatchDefault, + + + MultiCheckPatch, + constructorCheckPatch, + joinMultiCheckPatch, + mapErrorsWithInfoPatch, + + -- * Reexports + NP(..), DatatypeName, ConstructorName, FieldName + ) where + + +import Control.Validation.Check (Check(..), unsafeValidate, + CheckResult (Passed), + Unvalidated, + failsWith, mapError, checking, unsafeValidate, + unvalidated, validateBy) +import Control.Validation.Internal.SOP +import Data.Bifunctor (Bifunctor (second), + first) +import Generics.SOP as SOP(POP(..), unPOP, hliftA2, unK, NP(..), Generic(..), HasDatatypeInfo(..), DatatypeName, ConstructorName, FieldName, NS(..), SListI, hcexpand, hpure, SOP(..), I(..), unSOP, unI, hd, tl) +import Data.Foldable (Foldable (fold)) +import Data.Functor ((<&>)) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid (Ap (..)) +import Data.Sequence as Seq (Seq) +import qualified GHC.Generics as GHC(Generic) +import Data.Proxy(Proxy(..)) +import Lens.Micro (Lens') +import Lens.Micro.Extras (view) +import Control.Monad ((<=<)) +import Data.Bitraversable (Bitraversable(bitraverse)) + +-- $checkPatch +-- The 'CheckPatch' type is similar to 'Check' but accumulates a function that "fixes" your data i.e. corrects it where it fails a 'Check'. To do so, some +-- of the combinators take 'Lens'es instead of normal functions (see below). To lift a normal 'Check' to a 'CheckPatch' use 'checkPatch'. +-- to validate and fix your data with a 'CheckPatch' use 'validateByPatch'. + +newtype Patch a = Patch { runPatch :: a -> Maybe a } + +instance Semigroup (Patch a) where + {-# INLINE (<>) #-} + Patch f <> Patch g = Patch (f <=< g) + +instance Monoid (Patch a) where + {-# INLINE mempty #-} + mempty = Patch Just + + +-- | Helper functions to construct Patches. +patch :: (a -> a) -> Patch a +patch = Patch . (Just . ) + +noPatch :: Patch a +noPatch = Patch $ const Nothing + + +-- | A 'Check' that also corrects the errors in your data. +newtype CheckPatch e m a = CheckPatch (Check (e, Patch a) m a) + deriving (Monoid, Semigroup) +type CheckPatch' e = CheckPatch e Identity + +runCheckPatch :: CheckPatch e m a -> Unvalidated a -> m (CheckResult (e, Patch a)) +runCheckPatch (CheckPatch p) = runCheck p + +runCheckPatch' :: CheckPatch' e a -> Unvalidated a -> CheckResult (e, Patch a) +runCheckPatch' (CheckPatch p) = runIdentity . runCheck p + +overCheck :: (Check (e, Patch a) m a -> Check (e', Patch a') m' a') -> CheckPatch e m a -> CheckPatch e' m' a' +overCheck f (CheckPatch c) = CheckPatch (f c) + + + +-- | Lift a 'Check' to a 'CheckPatch' without a patch. +liftNoPatch :: Functor m => Check e m a -> CheckPatch e m a +liftNoPatch = CheckPatch . mapError (, noPatch) + + +-- | Lift a 'Check' to a 'CheckPatch' with a patch +liftPatch :: Functor m => (a -> Maybe a) -> Check e m a -> CheckPatch e m a +liftPatch p = CheckPatch . mapError (, Patch p) + +-- | Demote a 'CheckPatch' into a 'Check' by throwing the patch away +demotePatch :: Functor m => CheckPatch e m a -> Check e m a +demotePatch (CheckPatch c) = mapError fst c + +newtype Patched a = Patched { getPatched :: a } deriving (Show, Eq, Read, Generic) +-- | 'validateByPatch' takes a 'CheckPatch' and the unvalidated data and either returns the validated data or returns the errors in the data +-- and ─ if a fix exists ─ the fixed data. +validateByPatch :: forall m e a. Functor m => CheckPatch e m a -> Unvalidated a -> m (Either (Seq e, Maybe (Patched a)) a) +validateByPatch (CheckPatch c) v = applyChanges <$> validateBy c v + where + applyChanges :: Either (Seq (e, Patch a)) a -> Either (Seq e, Maybe (Patched a)) a + applyChanges (Right a) = Right a + applyChanges (Left s) = + let errs = fmap fst s :: Seq e + x' = Patched <$> runPatch (fold . fmap snd $ s) (unsafeValidate v) + in Left (errs, x') + +-- | 'validateByPatch' with trivial context +validateByPatch' :: CheckPatch' e a -> Unvalidated a -> Either (Seq e, Maybe (Patched a)) a +validateByPatch' c d = runIdentity . validateByPatch c $ d + +mapErrorPatch :: Functor m => (e -> e') -> CheckPatch e m a -> CheckPatch e' m a +mapErrorPatch f (CheckPatch c) = CheckPatch $ mapError (first f) c + + +-- * Variants of functions from "Control.Validation.Check" +-- $lens-variants +-- The functions 'contramapL', 'chooseL' and 'divideL' are the counterparts that take a lens instead of a simple function so they can patch their data if needed. +contramapL :: Functor m => Lens' s a -> CheckPatch e m a -> CheckPatch e m s +contramapL l = + overCheck $ mapError (second $ Patch . l . runPatch) + . contramap (view l) + + +traverseFirst :: forall f x x' y b. (Bitraversable b, Applicative f) => (x -> f x') -> b x y -> f (b x' y) +traverseFirst = flip bitraverse pure + +traverseSecond :: (Bitraversable b, Applicative f) => (y -> f y') -> b x y -> f (b x y') +traverseSecond = bitraverse pure + + +chooseL :: forall m a b c e. (Functor m) => (Lens' a (Either b c)) -> CheckPatch e m b -> CheckPatch e m c -> CheckPatch e m a +chooseL p (CheckPatch c1) (CheckPatch c2) = CheckPatch $ Check $ + either + (\input -> + fmap (second $ \(Patch f) -> Patch (p $ traverseFirst f)) + <$> runCheck c1 (unvalidated input) ) + (\input -> + fmap (second $ \(Patch f) -> Patch (p $ traverseSecond f)) + <$> runCheck c2 (unvalidated input) + ) + . view p + . unsafeValidate + + +divideL :: forall m a b c e. (Applicative m) => (Lens' a (b, c)) -> CheckPatch e m b -> CheckPatch e m c -> CheckPatch e m a +divideL p (CheckPatch c1) (CheckPatch c2) = CheckPatch $ Check $ \v -> case view p $ unsafeValidate v of + (b, c) -> getAp $ + ( Ap $ fmap (second $ \(Patch f) -> Patch (p $ traverseFirst f)) + <$> runCheck c1 (unvalidated b)) + <> + (Ap $ fmap (second $ \(Patch f) -> Patch (p $ traverseSecond f)) + <$> runCheck c2 (unvalidated c)) + + + + + + + +-- ** Construction of 'CheckPatch'es +-- $construction +-- Patch-variants for construction-functions. Functions have a `Patch` appended (e.g. 'test_' ~> 'testPatch_') and operators have an additional exclamation mark after the question mark +-- (e.g. '?>>' ~> '?!>>') +-- For documentation see "Control.Valiation.Check". +checkingPatch :: Functor m => (a -> (Maybe a, m (CheckResult e))) -> CheckPatch e m a +checkingPatch f = CheckPatch $ mapError ((, Patch $ fst . f)) $ checking (snd . f) + + + +checkingPatch' :: (a -> (Maybe a, CheckResult e)) -> CheckPatch' e a +checkingPatch' = checkingPatch . (second Identity .) + +testPatch' :: Applicative m => (a -> Bool) -> (a -> e) -> Patch a -> CheckPatch e m a +testPatch' p onErr fix = CheckPatch . Check $ \x -> pure $ if p . unsafeValidate $ x + then Passed + else failsWith (onErr $ unsafeValidate x, fix) +infix 7 `testPatch'` + + +{-# INLINE testPatch'_ #-} +testPatch'_ :: Applicative m => (a -> Bool) -> e -> Patch a -> CheckPatch e m a +testPatch'_ p err fix = testPatch' p (const err) fix +infix 7 `testPatch'_` + +testPatch :: Functor m => (a -> m Bool) -> (a -> e) -> Patch a -> CheckPatch e m a +testPatch p onErr fix = CheckPatch . Check $ \x -> p (unsafeValidate x) <&> \case + True -> Passed + False -> failsWith (onErr . unsafeValidate $ x, fix) +infix 7 `testPatch` + +{-# INLINE testPatch_ #-} +testPatch_ :: Monad m => (a -> m Bool) -> e -> Patch a -> CheckPatch e m a +testPatch_ p err fix = testPatch p (const err) fix +infix 7 `testPatch_` + + + + +-- | Patch by replacing with default value +testPatchDefault :: Applicative m => (a -> m Bool) -> (a -> e) -> a -> CheckPatch e m a +testPatchDefault p err def = testPatch p err (Patch $ const $ Just def) + + + +-- * Multi-'CheckPatch'es +-- $multiCheckPatch + +-- | A "Multi"-'CheckPatch' for an ADT, one 'CheckPatch e m' for each field of each constructor, organized in Lists (see examples for construction) +type MultiCheckPatch e m a = NP (NP (CheckPatch e m)) (Code a) + + + + +-- | Combine all 'CheckPatch's from a 'MultiCheckPatch' into a single 'CheckPatch' for the datatype 'a' (given it has a 'Generic' instance). +joinMultiCheckPatch :: forall a m e. (Applicative m, SOP.Generic a) + => MultiCheckPatch e m a + -> CheckPatch e m a +joinMultiCheckPatch = contramapL sopLensTo . joinCheckPatchPOP + + +-- | Change the error of a 'MultiCheckPatch' using the information about the datatype. +mapErrorsWithInfoPatch :: forall e e' a m. (Functor m, HasDatatypeInfo a) => Proxy a -> (DatatypeName -> ConstructorName -> FieldName -> e -> e') -> MultiCheckPatch e m a -> MultiCheckPatch e' m a +mapErrorsWithInfoPatch p f = unPOP . hliftA2 (mapErrorPatch . unK) (errMsgPOP p f) . POP + + + +constructorCheckPatch :: forall a m e xs. (Applicative m, Generic a) + => (NP (CheckPatch e m) xs -> NS (NP (CheckPatch e m)) (Code a)) -- ^ The function deciding the constructor, 'Z' for the zeroth, 'S . Z' for the first, etc. + -> NP (CheckPatch e m) xs -- ^ Product of 'CheckPatches', one for each constructor + -> CheckPatch e m a +constructorCheckPatch f = contramapL sopLensTo . joinCheckPatchPOP . hcexpand (Proxy @SListI) (hpure mempty) . f + + +-- internal functions + +joinCheckPatchPOP :: forall e m xss. (Applicative m) + => NP (NP (CheckPatch e m)) xss + -> CheckPatch e m (SOP I xss) +joinCheckPatchPOP Nil = mempty +joinCheckPatchPOP (ps :* pss) = CheckPatch . Check $ \uxss -> case unSOP $ unsafeValidate uxss of + Z xs -> changePatch (\p -> fmap SOP . tZ p . unSOP) $ runCheckPatch (joinCheckPatchNP ps) (unvalidated xs) + S xss -> changePatch (\p -> fmap SOP . tS (fmap unSOP . p . SOP) . unSOP) + $ runCheckPatch (joinCheckPatchPOP pss) (unvalidated $ SOP xss) + + +joinCheckPatchNP :: forall e m xs. (Applicative m) => NP (CheckPatch e m) xs -> CheckPatch e m (NP I xs) +joinCheckPatchNP Nil = mempty +joinCheckPatchNP (p :* ps) = + CheckPatch $ Check $ \uxs -> + let h = changePatch (tH . tI) $ runCheckPatch p + . fmap (unI . hd) + $ uxs + t = changePatch tT $ runCheckPatch (joinCheckPatchNP ps) . fmap tl $ uxs + in getAp $ Ap h <> Ap t + + + +joinCheckPatchNS :: forall e m xs. Applicative m => NP (CheckPatch e m) xs -> CheckPatch e m (NS I xs) +joinCheckPatchNS Nil = mempty +joinCheckPatchNS (p :* ps) = CheckPatch $ Check $ \uxs -> case unsafeValidate uxs of + Z (I x) -> changePatch (tZ . tI) $ runCheckPatch p . unvalidated $ x + S t -> changePatch tS . runCheckPatch (joinCheckPatchNS ps) . unvalidated $ t + + + + +changePatch :: Functor m => ((a -> Maybe a) -> (b -> Maybe b)) -> m (CheckResult (e, Patch a)) -> m (CheckResult (e, Patch b)) +changePatch f = fmap . fmap . fmap $ Patch . f . runPatch