{-# 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