{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ > 802 {-# LANGUAGE DerivingStrategies #-} #endif {- | Copyright: (c) 2014 Chris Allen, Edward Kmett (c) 2018-2020 Kowainik SPDX-License-Identifier: MIT Maintainer: Kowainik <xrom.xkov@gmail.com> Stability: Experimental Portability: Portable @since 0.4.0 = Attention __⚠️ Warning ⚠️__ This module is now deprecated @since 0.7.0.0. The whole module will be removed in the upcoming release. == Migration rules The module is deprecated in favour of [validation-selective](https://hackage.haskell.org/package/validation-selective). The package has the identical functionality, so can be easily migrated to. If you use "Relude.Extra.Validation" in you project you need to: 1. Add @validation-selective@ into the @build-depends@ section of your @.cabal@ file. 2. Change imports of "Relude.Extra.Validation" to "Validation": @ -- Was: import Relude.Extra.Validation (Validation (..), ..) -- Become: import Validation (Validation (..), ..) @ = Description 'Validation' is a monoidal sibling to 'Either' but 'Validation' doesn't have a 'Monad' instance. 'Validation' allows to accumulate all errors instead of short-circuiting on the first error so you can display all possible errors at once. Common use-cases include: 1. Validating each input of a form with multiple inputs. 2. Performing multiple validations of a single value. Instances of different standard typeclasses provide various semantics: 1. 'Functor': change the type inside 'Success'. 2. 'Bifunctor': change both 'Failure' and 'Success'. 3. 'Applicative': apply function to values inside 'Success' and accumulate errors inside 'Failure'. 4. 'Semigroup': accumulate both 'Failure' and 'Success' with '<>'. 5. 'Monoid': 'Success' that shores 'mempty'. 6. 'Alternative': return first 'Success' or accumulate all errors inside 'Failure'. -} module Relude.Extra.Validation ( -- * How to use -- $use Validation(..) , validationToEither , eitherToValidation ) where import GHC.TypeLits (ErrorMessage (..), TypeError) import Relude -- >>> $setup -- >>> import Relude {- $use Take for example a type @Computer@ that needs to be validated: >>> :{ data Computer = Computer { computerRam :: !Int -- ^ Ram in Gigabytes , computerCpus :: !Int } deriving (Eq, Show) :} You can validate that the computer has a minimum of 16GB of RAM: >>> :{ validateRam :: Int -> Validation [Text] Int validateRam ram | ram >= 16 = Success ram | otherwise = Failure ["Not enough RAM"] :} and that the processor has at least two CPUs: >>> :{ validateCpus :: Int -> Validation [Text] Int validateCpus cpus | cpus >= 2 = Success cpus | otherwise = Failure ["Not enough CPUs"] :} You can use these functions with the 'Applicative' instance of the 'Validation' type to construct a validated @Computer@. You will get either (pun intended) a valid @Computer@ or the errors that prevent it from being considered valid. Like so: >>> :{ mkComputer :: Int -> Int -> Validation [Text] Computer mkComputer ram cpus = Computer <$> validateRam ram <*> validateCpus cpus :} Using @mkComputer@ we get a @Success Computer@ or a list with all possible errors: >>> mkComputer 16 2 Success (Computer {computerRam = 16, computerCpus = 2}) >>> mkComputer 16 1 Failure ["Not enough CPUs"] >>> mkComputer 15 2 Failure ["Not enough RAM"] >>> mkComputer 15 1 Failure ["Not enough RAM","Not enough CPUs"] -} -- | 'Validation' is 'Either' with a 'Left' that is a 'Semigroup'. data Validation e a = Failure e | Success a #if __GLASGOW_HASKELL__ > 802 deriving stock (Eq, Ord, Show) #else deriving (Eq, Ord, Show) #endif {-# DEPRECATED Validation "Use 'Validation' from 'validation-selective' instead"#-} instance Functor (Validation e) where fmap :: (a -> b) -> Validation e a -> Validation e b fmap _ (Failure e) = Failure e fmap f (Success a) = Success (f a) {-# INLINE fmap #-} (<$) :: a -> Validation e b -> Validation e a x <$ Success _ = Success x _ <$ Failure e = Failure e {-# INLINE (<$) #-} {- | This instances covers the following cases: 1. Both 'Success': combine values inside 'Success' with '<>'. 2. Both 'Failure': combine values inside 'Failure' with '<>'. 3. One 'Success', one 'Failure': return 'Failure'. __Examples__ >>> success1 = Success [42] :: Validation [Text] [Int] >>> success2 = Success [69] :: Validation [Text] [Int] >>> failure1 = Failure ["WRONG"] :: Validation [Text] [Int] >>> failure2 = Failure ["FAIL"] :: Validation [Text] [Int] >>> success1 <> success2 Success [42,69] >>> failure1 <> failure2 Failure ["WRONG","FAIL"] >>> success1 <> failure1 Failure ["WRONG"] @since 0.6.0.0 -} instance (Semigroup e, Semigroup a) => Semigroup (Validation e a) where (<>) :: Validation e a -> Validation e a -> Validation e a (<>) = liftA2 (<>) {-# INLINE (<>) #-} {- | 'mempty' is @'Success' 'mempty'@. @since 0.6.0.0 -} instance (Semigroup e, Semigroup a, Monoid a) => Monoid (Validation e a) where mempty :: Validation e a mempty = Success mempty {-# INLINE mempty #-} mappend :: Validation e a -> Validation e a -> Validation e a mappend = (<>) {-# INLINE mappend #-} {- | This instance is the most important instance for the 'Validation' data type. It's responsible for the many implementations. And it allows to accumulate errors while performing validation or combining the results in the applicative style. __Examples__ >>> success1 = Success 42 :: Validation [Text] Int >>> success2 = Success 69 :: Validation [Text] Int >>> successF = Success (* 2) :: Validation [Text] (Int -> Int) >>> failure1 = Failure ["WRONG"] :: Validation [Text] Int >>> failure2 = Failure ["FAIL"] :: Validation [Text] Int >>> successF <*> success1 Success 84 >>> successF <*> failure1 Failure ["WRONG"] >>> (+) <$> success1 <*> success2 Success 111 >>> (+) <$> failure1 <*> failure2 Failure ["WRONG","FAIL"] >>> liftA2 (+) success1 failure1 Failure ["WRONG"] >>> liftA3 (,,) failure1 success1 failure2 Failure ["WRONG","FAIL"] Implementations of all functions are lazy and they correctly work if some arguments are not fully evaluated. >>> :{ isFailure :: Validation e a -> Bool isFailure (Failure _) = True isFailure (Success _) = False :} >>> failure1 *> failure2 Failure ["WRONG","FAIL"] >>> isFailure $ failure1 *> failure2 True >>> epicFail = error "Impossible validation" :: Validation [Text] Int >>> isFailure $ failure1 *> epicFail True -} instance Semigroup e => Applicative (Validation e) where pure :: a -> Validation e a pure = Success {-# INLINE pure #-} (<*>) :: Validation e (a -> b) -> Validation e a -> Validation e b Failure e <*> b = Failure $ case b of Failure e' -> e <> e' Success _ -> e Success _ <*> Failure e = Failure e Success f <*> Success a = Success (f a) {-# INLINE (<*>) #-} (*>) :: Validation e a -> Validation e b -> Validation e b Failure e *> b = Failure $ case b of Failure e' -> e <> e' Success _ -> e Success _ *> Failure e = Failure e Success _ *> Success b = Success b {-# INLINE (*>) #-} (<*) :: Validation e a -> Validation e b -> Validation e a Failure e <* b = Failure $ case b of Failure e' -> e <> e' Success _ -> e Success _ <* Failure e = Failure e Success a <* Success _ = Success a {-# INLINE (<*) #-} {- | This instance implements the following behavior for the binary operator: 1. Both 'Failure': combine values inside 'Failure' using '<>'. 2. At least is 'Success': return the left 'Success' (the earliest 'Success'). 3. 'empty' is @'Failure' 'mempty'@. __Examples__ >>> success1 = Success [42] :: Validation [Text] [Int] >>> success2 = Success [69] :: Validation [Text] [Int] >>> failure1 = Failure ["WRONG"] :: Validation [Text] [Int] >>> failure2 = Failure ["FAIL"] :: Validation [Text] [Int] >>> success1 <|> success2 Success [42] >>> failure1 <|> failure2 Failure ["WRONG","FAIL"] >>> failure2 <|> success2 Success [69] -} instance (Semigroup e, Monoid e) => Alternative (Validation e) where empty :: Validation e a empty = Failure mempty {-# INLINE empty #-} (<|>) :: Validation e a -> Validation e a -> Validation e a s@Success{} <|> _ = s _ <|> s@Success{} = s Failure e <|> Failure e' = Failure (e <> e') {-# INLINE (<|>) #-} instance Foldable (Validation e) where fold :: Monoid m => Validation e m -> m fold (Success a) = a fold (Failure _) = mempty {-# INLINE fold #-} foldMap :: Monoid m => (a -> m) -> Validation e a -> m foldMap _ (Failure _) = mempty foldMap f (Success a) = f a {-# INLINE foldMap #-} foldr :: (a -> b -> b) -> b -> Validation e a -> b foldr f x (Success a) = f a x foldr _ x (Failure _) = x {-# INLINE foldr #-} instance Traversable (Validation e) where traverse :: Applicative f => (a -> f b) -> Validation e a -> f (Validation e b) traverse f (Success a) = Success <$> f a traverse _ (Failure e) = pure (Failure e) {-# INLINE traverse #-} sequenceA :: Applicative f => Validation e (f a) -> f (Validation e a) sequenceA = traverse id {-# INLINE sequenceA #-} instance Bifunctor Validation where bimap :: (e -> d) -> (a -> b) -> Validation e a -> Validation d b bimap f _ (Failure e) = Failure (f e) bimap _ g (Success a) = Success (g a) {-# INLINE bimap #-} first :: (e -> d) -> Validation e a -> Validation d a first f (Failure e) = Failure (f e) first _ (Success a) = Success a {-# INLINE first #-} second :: (a -> b) -> Validation e a -> Validation e b second _ (Failure e) = Failure e second g (Success a) = Success (g a) {-# INLINE second #-} #if MIN_VERSION_base(4,10,0) instance Bifoldable Validation where bifoldMap :: Monoid m => (e -> m) -> (a -> m) -> Validation e a -> m bifoldMap f _ (Failure e) = f e bifoldMap _ g (Success a) = g a {-# INLINE bifoldMap #-} instance Bitraversable Validation where bitraverse :: Applicative f => (e -> f d) -> (a -> f b) -> Validation e a -> f (Validation d b) bitraverse f _ (Failure e) = Failure <$> f e bitraverse _ g (Success a) = Success <$> g a {-# INLINE bitraverse #-} #endif {- | Transform a 'Validation' into an 'Either'. >>> validationToEither (Success "whoop") Right "whoop" >>> validationToEither (Failure "nahh") Left "nahh" -} validationToEither :: Validation e a -> Either e a validationToEither = \case Failure e -> Left e Success a -> Right a {-# INLINE validationToEither #-} {-# DEPRECATED validationToEither "Use 'validationToEither' from 'validation-selective' instead"#-} {- | Transform an 'Either' into a 'Validation'. >>> eitherToValidation (Right "whoop") Success "whoop" >>> eitherToValidation (Left "nahh") Failure "nahh" -} eitherToValidation :: Either e a -> Validation e a eitherToValidation = \case Left e -> Failure e Right a -> Success a {-# INLINE eitherToValidation #-} {-# DEPRECATED eitherToValidation "Use 'eitherToValidation' from 'validation-selective' instead"#-} ---------------------------------------------------------------------------- -- Custom errors ---------------------------------------------------------------------------- {- | ⚠️__CAUTION__⚠️ This instance is for custom error display only. It's not possible to implement lawful 'Monad' instance for 'Validation'. In case it is used by mistake, the user will see the following: >>> Success 42 >>= \n -> if even n then Success n else Failure ["Not even"] ... ... Type 'Validation' doesn't have lawful 'Monad' instance which means that you can't use 'Monad' methods with 'Validation'. ... @since 0.6.0.0 -} instance (NoValidationMonadError, Semigroup e) => Monad (Validation e) where return = error "Unreachable Validation instance of Monad" (>>=) = error "Unreachable Validation instance of Monad" -- | Helper type family to produce error messages type family NoValidationMonadError :: Constraint where NoValidationMonadError = TypeError ( 'Text "Type 'Validation' doesn't have lawful 'Monad' instance" ':$$: 'Text "which means that you can't use 'Monad' methods with 'Validation'." )