{-|
Module : Validation
Description : Validation types/typeclass that allow for effectful validation and easy composition.
Copyright : (c) Fabian Birkmann 2020
License : GPL-3
Maintainer : 99fabianb@sis.gl
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].
-}
{-# LANGUAGE
PolyKinds, TypeOperators, LambdaCase,
DerivingStrategies, DerivingVia, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveGeneric
#-}
module Control.Validation.Check(
-- * Unvalidated values
-- $unvalidated
--
Unvalidated(..), unvalidated,
-- * Types for checks
--
-- ** Check results
-- $checkResults
--
CheckResult(..),
checkResult, failsWith, failsNoMsg, passed, failed, checkResultToEither,
-- ** The Check type
-- $check
--
Check(..), Check',
passOnRight, mapError, generalizeCheck,
validateBy, validateBy',
-- *** Constructing checks
-- $constructingChecks
--
checking, checking',
test, (?~>),
test', (?>),
test_, (?~>>),
test'_,(?>>),
-- ** Helper for deriving Checkable
-- $derivHelper
foldWithCheck, traverseWithCheck,
-- * Reexports
hoist, contramap
) where
import Data.Kind (Type)
import GHC.Generics (Generic)
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(..))
import Data.Foldable (fold)
import Data.Monoid (Ap(..))
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`):
--
-- > 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)
{-# INLINE unvalidated #-}
unvalidated :: a -> Unvalidated a
unvalidated = Unvalidated
----------------------------------------------------------------------------------
-- = Types for checks
-- == Check results
-- $checkResults
-- 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)
instance Semigroup (CheckResult e) where
Passed <> x = x
Failed s1 <> Passed = Failed s1
Failed s1 <> Failed s2 = Failed (s1 <> s2)
instance Monoid (CheckResult e) where
mempty = Passed
failsWith :: e -> CheckResult e
failsWith = Failed . Seq.singleton
-- | Throwing an error without a message.
failsNoMsg :: CheckResult e
failsNoMsg = Failed mempty
-- | A fold for 'CheckResult'
checkResult :: a -> (Seq e -> a) -> CheckResult e -> a
checkResult x _ Passed = x
checkResult _ f (Failed e) = f e
passed, failed :: CheckResult e -> Bool
passed = checkResult True (const False)
failed = checkResult False (const True)
checkResultToEither :: a -- ^ default value
-> CheckResult e
-> Either (Seq e) a
checkResultToEither x = checkResult (Right x) Left
----------------------------------------------------------------------------------
-- ** The Check type
-- $check
-- 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`
-- 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
-- >
-- > 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 }
-- >
-- > check404 :: Check () IO Url -- checks if the url returns 404
-- >
-- > checkHttps :: Check' () Identity Url
-- > checkHttps = ("https" `isPrefixOf`) ?>> ()
-- >
-- > checkUrl :: Check () IO Url
-- > checkUrl = check404 <> hoist generalize checkHttps
--
-- For more information see the README.
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)))
instance MFunctor (Check e) where
hoist f = withCheck (f .)
withCheck :: ( (Unvalidated a -> m (CheckResult d))
-> Unvalidated b -> n (CheckResult e))
-> Check d m a -> Check e n b
withCheck f = Check . f . runCheck
-- | 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' for trivial context.
validateBy' :: Check' e a -> Unvalidated a -> Either (Seq e) a
validateBy' c = runIdentity . validateBy c
-- | A 'Check' with a trivial context
type Check' e = Check e Identity
-- | Generalize a 'Check' without context to any 'Check' with an applicative context
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
-- 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 ()
-- > x:xs -> Left (x, xs))
-- > ( divide id c (checkList c))
passOnRight :: Applicative m => (a -> Either b ()) -> Check e m b -> Check e m a
passOnRight f c = choose f c mempty
-- | Mapping over the error type.
mapError :: Functor m => (e -> e') -> Check e m a -> Check e' m a
mapError f = withCheck (fmap (fmap f) .)
------------------------------------------------------------------------------------------------------
-- === Construction of 'Check's
-- $constructingChecks
-- Constructing a check from a predicate. Naming conventions:
--
-- * Functions that work on trivial contexts are prefixed 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' :: (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
then Passed
else failsWith (onErr x)
infix 7 `test'`
{-# INLINE (?>) #-}
(?>) = test'
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
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
True -> Passed
False -> failsWith . onErr $ x
infix 7 `test`
{-# INLINE (?~>) #-}
(?~>) = test
infix 7 ?~>
-- > 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
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)
-- | Lift a check to a traversable
traverseWithCheck :: (Traversable t, Applicative m) => Check e m a -> Check e m (t a)
traverseWithCheck c = checking $ fmap fold . traverse (runCheck c . unvalidated)