diff options
Diffstat (limited to 'validation/src/Data')
-rw-r--r-- | validation/src/Data/Validation.hs | 375 |
1 files changed, 0 insertions, 375 deletions
diff --git a/validation/src/Data/Validation.hs b/validation/src/Data/Validation.hs deleted file mode 100644 index e30202f..0000000 --- a/validation/src/Data/Validation.hs +++ /dev/null @@ -1,375 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - --- | A data type similar to @Data.Either@ that accumulates failures. -module Data.Validation -( - -- * Data type - Validation(..) - -- * Constructing validations -, validate -, validationNel -, fromEither -, liftError - -- * Functions on validations -, validation -, toEither -, orElse -, valueOr -, ensure -, codiagonal -, validationed -, bindValidation - -- * Prisms - -- | These prisms are useful for writing code which is polymorphic in its - -- choice of Either or Validation. This choice can then be made later by a - -- user, depending on their needs. - -- - -- An example of this style of usage can be found - -- <https://github.com/qfpl/validation/blob/master/examples/src/PolymorphicEmail.hs here> -, _Failure -, _Success - -- * Isomorphisms -, Validate(..) -, revalidate -) where - -import Control.Applicative (Applicative (pure, (<*>)), (<$>)) -import Control.DeepSeq (NFData (rnf)) -import Control.Lens (over, under) -import Control.Lens.Getter ((^.)) -import Control.Lens.Iso (Iso, Swapped (..), from, iso) -import Control.Lens.Prism (Prism, prism) -import Control.Lens.Review (( # )) -import Data.Bifoldable (Bifoldable (bifoldr)) -import Data.Bifunctor (Bifunctor (bimap)) -import Data.Bitraversable (Bitraversable (bitraverse)) -import Data.Data (Data) -import Data.Either (Either (Left, Right), either) -import Data.Eq (Eq) -import Data.Foldable (Foldable (foldr)) -import Data.Function (id, ($), (.)) -import Data.Functor (Functor (fmap)) -import Data.Functor.Alt (Alt ((<!>))) -import Data.Functor.Apply (Apply ((<.>))) -import Data.List.NonEmpty (NonEmpty) -import Data.Monoid (Monoid (mappend, mempty)) -import Data.Ord (Ord) -import Data.Semigroup (Semigroup ((<>))) -import Data.Traversable (Traversable (traverse)) -import Data.Typeable (Typeable) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -import Prelude (Maybe (..), Show) - - --- | An @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However, --- the 'Applicative' instance for @Validation@ /accumulates/ errors using a 'Semigroup' on @err@. --- In contrast, the @Applicative@ for @Either@ returns only the first error. --- --- A consequence of this is that @Validation@ has no 'Data.Functor.Bind.Bind' or 'Control.Monad.Monad' instance. This is because --- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the --- @Applicative@'s 'Control.Applicative.<*>' --- --- An example of typical usage can be found <https://github.com/qfpl/validation/blob/master/examples/src/Email.hs here>. --- -data Validation err a = - Failure err - | Success a - deriving ( - Eq, Ord, Show, Data, Typeable -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif - ) - -instance Functor (Validation err) where - fmap _ (Failure e) = - Failure e - fmap f (Success a) = - Success (f a) - {-# INLINE fmap #-} - -instance Semigroup err => Apply (Validation err) where - Failure e1 <.> b = Failure $ case b of - Failure e2 -> e1 <> e2 - Success _ -> e1 - Success _ <.> Failure e2 = - Failure e2 - Success f <.> Success a = - Success (f a) - {-# INLINE (<.>) #-} - -instance Semigroup err => Applicative (Validation err) where - pure = - Success - (<*>) = - (<.>) - --- | For two errors, this instance reports only the last of them. -instance Alt (Validation err) where - Failure _ <!> x = - x - Success a <!> _ = - Success a - {-# INLINE (<!>) #-} - -instance Foldable (Validation err) where - foldr f x (Success a) = - f a x - foldr _ x (Failure _) = - x - {-# INLINE foldr #-} - -instance Traversable (Validation err) where - traverse f (Success a) = - Success <$> f a - traverse _ (Failure e) = - pure (Failure e) - {-# INLINE traverse #-} - -instance Bifunctor Validation where - bimap f _ (Failure e) = - Failure (f e) - bimap _ g (Success a) = - Success (g a) - {-# INLINE bimap #-} - - -instance Bifoldable Validation where - bifoldr _ g x (Success a) = - g a x - bifoldr f _ x (Failure e) = - f e x - {-# INLINE bifoldr #-} - -instance Bitraversable Validation where - bitraverse _ g (Success a) = - Success <$> g a - bitraverse f _ (Failure e) = - Failure <$> f e - {-# INLINE bitraverse #-} - -appValidation :: - (err -> err -> err) - -> Validation err a - -> Validation err a - -> Validation err a -appValidation m (Failure e1) (Failure e2) = - Failure (e1 `m` e2) -appValidation _ (Failure _) (Success a2) = - Success a2 -appValidation _ (Success a1) (Failure _) = - Success a1 -appValidation _ (Success a1) (Success _) = - Success a1 -{-# INLINE appValidation #-} - -instance Semigroup e => Semigroup (Validation e a) where - (<>) = - appValidation (<>) - {-# INLINE (<>) #-} - -instance Monoid e => Monoid (Validation e a) where - mappend = - appValidation mappend - {-# INLINE mappend #-} - mempty = - Failure mempty - {-# INLINE mempty #-} - -instance Swapped Validation where - swapped = - iso - (\v -> case v of - Failure e -> Success e - Success a -> Failure a) - (\v -> case v of - Failure a -> Success a - Success e -> Failure e) - {-# INLINE swapped #-} - -instance (NFData e, NFData a) => NFData (Validation e a) where - rnf v = - case v of - Failure e -> rnf e - Success a -> rnf a - --- | 'validate's an @a@ producing an updated optional value, returning --- @e@ in the empty case. --- --- This can be thought of as having the less general type: --- --- @ --- validate :: e -> (a -> Maybe b) -> a -> Validation e b --- @ -validate :: Validate v => e -> (a -> Maybe b) -> a -> v e b -validate e p a = case p a of - Nothing -> _Failure # e - Just b -> _Success # b - --- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since --- they are a common semigroup to use. -validationNel :: Either e a -> Validation (NonEmpty e) a -validationNel = liftError pure - --- | Converts from 'Either' to 'Validation'. -fromEither :: Either e a -> Validation e a -fromEither = liftError id - --- | 'liftError' is useful for converting an 'Either' to an 'Validation' --- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'. -liftError :: (b -> e) -> Either b a -> Validation e a -liftError f = either (Failure . f) Success - --- | 'validation' is the catamorphism for @Validation@. -validation :: (e -> c) -> (a -> c) -> Validation e a -> c -validation ec ac v = case v of - Failure e -> ec e - Success a -> ac a - --- | Converts from 'Validation' to 'Either'. -toEither :: Validation e a -> Either e a -toEither = validation Left Right - --- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@. --- --- This can be thought of as having the less general type: --- --- @ --- orElse :: Validation e a -> a -> a --- @ -orElse :: Validate v => v e a -> a -> a -orElse v a = case v ^. _Validation of - Failure _ -> a - Success x -> x - --- | Return the @a@ or run the given function over the @e@. --- --- This can be thought of as having the less general type: --- --- @ --- valueOr :: (e -> a) -> Validation e a -> a --- @ -valueOr :: Validate v => (e -> a) -> v e a -> a -valueOr ea v = case v ^. _Validation of - Failure e -> ea e - Success a -> a - --- | 'codiagonal' gets the value out of either side. -codiagonal :: Validation a a -> a -codiagonal = valueOr id - --- | 'ensure' ensures that a validation remains unchanged upon failure, --- updating a successful validation with an optional value that could fail --- with @e@ otherwise. --- --- This can be thought of as having the less general type: --- --- @ --- ensure :: e -> (a -> Maybe b) -> Validation e a -> Validation e b --- @ -ensure :: Validate v => e -> (a -> Maybe b) -> v e a -> v e b -ensure e p = - over _Validation $ \v -> case v of - Failure x -> Failure x - Success a -> validate e p a - --- | Run a function on anything with a Validate instance (usually Either) --- as if it were a function on Validation --- --- This can be thought of as having the type --- --- @(Either e a -> Either e' a') -> Validation e a -> Validation e' a'@ -validationed :: Validate v => (v e a -> v e' a') -> Validation e a -> Validation e' a' -validationed f = under _Validation f - --- | @bindValidation@ binds through an Validation, which is useful for --- composing Validations sequentially. Note that despite having a bind --- function of the correct type, Validation is not a monad. --- The reason is, this bind does not accumulate errors, so it does not --- agree with the Applicative instance. --- --- There is nothing wrong with using this function, it just does not make a --- valid @Monad@ instance. -bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b -bindValidation v f = case v of - Failure e -> Failure e - Success a -> f a - --- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic --- to Validation, and hence isomorphic to Either. -class Validate f where - _Validation :: - Iso (f e a) (f g b) (Validation e a) (Validation g b) - - _Either :: - Iso (f e a) (f g b) (Either e a) (Either g b) - _Either = - iso - (\x -> case x ^. _Validation of - Failure e -> Left e - Success a -> Right a) - (\x -> _Validation # case x of - Left e -> Failure e - Right a -> Success a) - {-# INLINE _Either #-} - -instance Validate Validation where - _Validation = - id - {-# INLINE _Validation #-} - _Either = - iso - (\x -> case x of - Failure e -> Left e - Success a -> Right a) - (\x -> case x of - Left e -> Failure e - Right a -> Success a) - {-# INLINE _Either #-} - -instance Validate Either where - _Validation = - iso - fromEither - toEither - {-# INLINE _Validation #-} - _Either = - id - {-# INLINE _Either #-} - --- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'Validation'. -_Failure :: - Validate f => - Prism (f e1 a) (f e2 a) e1 e2 -_Failure = - prism - (\x -> _Either # Left x) - (\x -> case x ^. _Either of - Left e -> Right e - Right a -> Left (_Either # Right a)) -{-# INLINE _Failure #-} - --- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'Validation'. -_Success :: - Validate f => - Prism (f e a) (f e b) a b -_Success = - prism - (\x -> _Either # Right x) - (\x -> case x ^. _Either of - Left e -> Left (_Either # Left e) - Right a -> Right a) -{-# INLINE _Success #-} - --- | 'revalidate' converts between any two instances of 'Validate'. -revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t) -revalidate = _Validation . from _Validation |