{-# LANGUAGE
LambdaCase, DerivingStrategies, DerivingVia, StandaloneDeriving, KindSignatures, GeneralizedNewtypeDeriving,
PolyKinds, TypeOperators,
DefaultSignatures, InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances
#-}
module Control.Validation.Class(
-- * Checkable
-- $checkable
validate, validate',
CheckChain(..), overChain, (+?+), singleChain,
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 Data.ByteString(ByteString)
import Data.Text(Text)
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(..))
------------------------------------------------------------------------------------------------------
-- $checkable
-- = 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
-- 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
-- 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
-- not combined via '(<>)', see the point for `isValid`.
--
-- * 'defaulCheck': A check performing all checks of 'checkChain'
--
-- > defaultCheck = fold checkChain
--
-- * 'isValid': A function determining whether a value is valid.
-- This functions stops checking after the first of the checks
-- from 'checkChain' fails .This function is the reason why we
-- need the 'checkChain', as a 'Check' constructed by '(<>)'
-- 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) =
CheckChain { runCheckChain :: [ Check e m a ] }
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
-- | Convenience synonym.
{-# INLINE (+?+) #-}
(+?+) :: CheckChain e m a -> CheckChain e m a -> CheckChain e m a
(+?+) = (<>)
infixr 5 +?+ -- so it behaves like list concatenation
{-# INLINE emptyChain #-}
emptyChain :: CheckChain e m a
emptyChain = mempty
{-# INLINE singleChain #-}
singleChain :: Check e m a -> CheckChain e m a
singleChain x = CheckChain [ x ]
-- These are the functions that make use of the typeclass:
{-# INLINABLE validate' #-}
validate' :: Validatable e Identity a => Unvalidated a -> Either (Seq e) a
validate' u@(Unvalidated x) =
checkResultToEither x
. 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
$ u
class Validatable (e :: Type) (m :: Type -> Type) (a :: Type) | a -> m, a -> e where
checkChain :: CheckChain e m a
default checkChain :: (Generic a, GValidatable e m (Rep a)) => CheckChain e m a
checkChain = contramap from gCheckChain
defaultCheck :: Check e m a
default defaultCheck :: Applicative m => Check e m a
defaultCheck = fold . runCheckChain $ checkChain
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 Int32 instance Validatable Void Identity Int32
deriving via TrivialCheck Int64 instance Validatable Void Identity Int64
deriving via TrivialCheck Integer instance Validatable Void Identity Integer
deriving via TrivialCheck ByteString instance Validatable Void Identity ByteString
deriving via TrivialCheck Text instance Validatable Void Identity Text
instance (Validatable e m a, Applicative m) => (Validatable e m (Maybe a)) where
checkChain = traverseWithCheck `overChain` checkChain
instance (Validatable e m b, Validatable e m a, Applicative m) => Validatable e m (Either a b) where
checkChain = traverseWithCheck `overChain` checkChain
instance (Validatable e m a, Applicative m) => (Validatable e m [a]) where
checkChain = traverseWithCheck `overChain` checkChain
------------------------------------------------------------------------------------------------------
-- $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)
newtype TrivialCheck a = TrivialCheck { unTrivialCheck :: a }
instance Validatable Void Identity (TrivialCheck a) where
{-# INLINE checkChain #-}
checkChain = emptyChain
{-# INLINE defaultCheck #-}
defaultCheck = mempty
{-# INLINE isValid #-}
isValid = const (Identity True)
------------------------------------------------------------------------------------------------------
-- The generic instance
class GValidatable (e :: Type) (m :: Type -> Type) (rep :: k -> Type) | rep -> m, rep -> e where
gCheckChain :: CheckChain e m (rep x)
instance GValidatable Void Identity V1 where
gCheckChain = mempty
instance GValidatable Void Identity U1 where
gCheckChain = mempty
instance Validatable e m a => GValidatable e m (K1 i a) where
gCheckChain :: CheckChain e m (K1 i a x)
gCheckChain = contramap unK1 checkChain
instance (Applicative m, GValidatable e m f, GValidatable e m g) => GValidatable e m (f :*: g) where
gCheckChain = divide id_tup gCheckChain gCheckChain
where id_tup (x :*: y) = (x, y)
instance (GValidatable e m f, GValidatable e m g, Applicative m) => GValidatable e m (f :+: g) where
gCheckChain = choose id_sum gCheckChain gCheckChain
where id_sum = \case
L1 l -> Left l
R1 r -> Right r
instance (GValidatable e m rep) => GValidatable e m (M1 i c rep) where
gCheckChain = contramap unM1 gCheckChain