validation-1.2.2: src/Data/Validation.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}

-- \$setup
-- >>> import Prelude hiding (either, id, (.))
-- >>> import Data.List.NonEmpty(NonEmpty(..))
-- >>> import Data.Semigroup(Semigroup((<>)))
-- >>> import Control.Lens((^?), (#), review, view, from, _Wrapped')
-- >>> import Data.Functor.Alt(Alt((<!>)))
-- >>> import Data.Functor.Apply(Apply((<.>)))
-- >>> import Control.DeepSeq(rnf)
-- >>> import Control.Category(id, (.))
-- >>> import Data.Semigroupoid(Semigroupoid(o))
-- >>> import Data.Profunctor(Profunctor(dimap), Strong(first'), Choice(left'))
-- >>> import Control.Arrow(Arrow(arr, first), ArrowApply(app), ArrowChoice(left))
-- >>> import Control.Selective(Selective(select))
-- >>> import Data.Bifunctor(Bifunctor(bimap))
-- >>> import Data.Bifoldable(Bifoldable(bifoldr))
-- >>> import Data.Bitraversable(Bitraversable(bitraverse))
-- >>> import Data.Bifunctor.Swap(Swap(swap))
-- >>> import Data.Tagged(Tagged(..))
-- >>> :set -XNoMonomorphismRestriction -w

-- | A data type similar to @Data.Either@ that accumulates failures.
module Data.Validation
  ( -- * Data type
    Validation (..),

    -- * Catamorphism
    foldValidation,

    -- * Optics

    -- ** Classy lenses (as generated by @makeClassy@)
    GetValidation (..),
    HasValidation (..),

    -- ** Classy prisms (as generated by @makeClassyPrisms@)
    ReviewValidation (..),
    AsValidation (..),
    GetFailure (..),
    HasFailure (..),
    ReviewFailure (..),
    AsFailure (..),
    GetSuccess (..),
    HasSuccess (..),
    ReviewSuccess (..),
    AsSuccess (..),

    -- ** Prisms
    __Failure,
    __Success,

    -- ** Isomorphisms
    Data.Validation.either,
    codiagonal,

    -- * Validator
    Validator (..),
    Validator',

    -- ** Classy lenses
    GetValidator (..),
    HasValidator (..),

    -- ** Classy prisms
    ReviewValidator (..),
    AsValidator (..),

    -- ** Isomorphisms
    unitValidator,
    taggedValidator,
    swapValidator,

    -- ** Profunctor newtypes
    Iso'' (..),
    Prism'' (..),

    -- ** Example validators
    nonEmptyListIsoValidator',
    nonEmptyListIsoValidator,
    nonEmptyListPrismValidator',
    nonEmptyListPrismValidator,
  )
where

import Control.Arrow (Arrow (arr, first), ArrowApply (app), ArrowChoice (left, right))
import Control.Category (Category (..), (>>>))
import Control.DeepSeq (NFData (rnf))
import Control.Lens (Getter, Lens', Prism, Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), prism, prism')
import Control.Lens.Iso (Iso, iso
#if !MIN_VERSION_lens(4,20,0)
                       , Swapped(..))
#else
                       )
#endif
import Control.Selective (Selective (..))
import Data.Bifoldable (Bifoldable (bifoldr))
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bifunctor.Swap (Swap (..))
import Data.Bitraversable (Bitraversable (bitraverse))
import Data.Bool (bool)
import Data.Data (Data)
import qualified Data.Either as Either
import Data.Functor.Alt (Alt ((<!>)))
import Data.Functor.Apply (Apply ((<.>)))
import Data.List.NonEmpty (NonEmpty (..), toList)
import Data.Profunctor (Choice (left', right'), Profunctor (dimap, lmap, rmap), Strong (first', second'))
import Data.Semigroupoid (Semigroupoid (o))
import Data.Tagged (Tagged (..))
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)
import GHC.Generics (Generic)
import Prelude hiding (either, id, (.))

-- | A @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 (Data, Eq, Generic, Ord, Show, Typeable)

-- |
-- >>> fmap (+1) (Success 2 :: Validation String Int)
-- Success 3
--
-- >>> fmap (+1) (Failure "err" :: Validation String Int)
-- Failure "err"
instance Functor (Validation err) where
  fmap _ (Failure e) =
    Failure e
  fmap f (Success a) =
    Success (f a)
  {-# INLINE fmap #-}

-- | Accumulates errors on the left using 'Semigroup'.
--
-- >>> import Data.Functor.Apply(Apply((<.>)))
-- >>> Success (+1) <.> Success 2 :: Validation [String] Int
-- Success 3
--
-- >>> Failure ["e1"] <.> Success 2 :: Validation [String] Int
-- Failure ["e1"]
--
-- >>> Success (+1) <.> Failure ["e2"] :: Validation [String] Int
-- Failure ["e2"]
--
-- >>> Failure ["e1"] <.> Failure ["e2"] :: Validation [String] Int
-- Failure ["e1","e2"]
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 (<.>) #-}

-- | Delegates to the 'Apply' instance, accumulating errors with '<>'.
--
-- >>> pure (+1) <*> pure 2 :: Validation [String] Int
-- Success 3
--
-- >>> Failure ["e1"] <*> Failure ["e2"] :: Validation [String] Int
-- Failure ["e1","e2"]
instance (Semigroup err) => Applicative (Validation err) where
  pure =
    Success
  {-# INLINE pure #-}
  (<*>) =
    (<.>)
  {-# INLINE (<*>) #-}

-- | Tries the left, then the right, accumulating errors on two failures.
--
-- >>> import Data.Functor.Alt(Alt((<!>)))
-- >>> Success 1 <!> Success 2 :: Validation [String] Int
-- Success 1
--
-- >>> Failure ["e1"] <!> Success 2 :: Validation [String] Int
-- Success 2
--
-- >>> Success 1 <!> Failure ["e2"] :: Validation [String] Int
-- Success 1
--
-- >>> Failure ["e1"] <!> Failure ["e2"] :: Validation [String] Int
-- Failure ["e1","e2"]
instance (Semigroup err) => Alt (Validation err) where
  Failure e1 <!> Failure e2 =
    Failure (e1 <> e2)
  Failure _ <!> Success a =
    Success a
  Success a <!> _ =
    Success a
  {-# INLINE (<!>) #-}

-- | Skips the second effect on 'Failure'.
--
-- >>> import Control.Selective(Selective(select))
-- >>> select (Success (Right 1)) (Success (+1)) :: Validation [String] Int
-- Success 1
--
-- >>> select (Success (Left 1)) (Success (+1)) :: Validation [String] Int
-- Success 2
--
-- >>> select (Failure ["e1"]) (Success (+1)) :: Validation [String] Int
-- Failure ["e1"]
--
-- >>> select (Failure ["e1"]) (Failure ["e2"]) :: Validation [String] Int
-- Failure ["e1"]
instance (Semigroup err) => Selective (Validation err) where
  select (Failure e) _ = Failure e
  select (Success x) f = Either.either (\a -> ($ a) <$> f) Success x
  {-# INLINE select #-}

-- |
-- >>> foldr (:) [] (Success 1 :: Validation String Int)
-- [1]
--
-- >>> foldr (:) [] (Failure "err" :: Validation String Int)
-- []
instance Foldable (Validation err) where
  foldr f x (Success a) =
    f a x
  foldr _ x (Failure _) =
    x
  {-# INLINE foldr #-}

-- |
-- >>> traverse (\x -> [x, x+1]) (Success 1 :: Validation String Int)
-- [Success 1,Success 2]
--
-- >>> traverse (\x -> [x, x+1]) (Failure "err" :: Validation String Int)
-- [Failure "err"]
instance Traversable (Validation err) where
  traverse f (Success a) =
    Success <$> f a
  traverse _ (Failure e) =
    pure (Failure e)
  {-# INLINE traverse #-}

-- |
-- >>> import Data.Bifunctor(Bifunctor(bimap))
-- >>> bimap show (+1) (Failure 1 :: Validation Int Int)
-- Failure "1"
--
-- >>> bimap show (+1) (Success 1 :: Validation Int Int)
-- Success 2
instance Bifunctor Validation where
  bimap f _ (Failure e) =
    Failure (f e)
  bimap _ g (Success a) =
    Success (g a)
  {-# INLINE bimap #-}

-- |
-- >>> import Data.Bifoldable(Bifoldable(bifoldr))
-- >>> bifoldr (\e r -> show e ++ r) (\a r -> show a ++ r) "" (Failure 1 :: Validation Int Int)
-- "1"
--
-- >>> bifoldr (\e r -> show e ++ r) (\a r -> show a ++ r) "" (Success 2 :: Validation Int Int)
-- "2"
instance Bifoldable Validation where
  bifoldr _ g x (Success a) =
    g a x
  bifoldr f _ x (Failure e) =
    f e x
  {-# INLINE bifoldr #-}

-- |
-- >>> import Data.Bitraversable(Bitraversable(bitraverse))
-- >>> bitraverse (\e -> [e, e+1]) (\a -> [a, a*2]) (Failure 1 :: Validation Int Int)
-- [Failure 1,Failure 2]
--
-- >>> bitraverse (\e -> [e, e+1]) (\a -> [a, a*2]) (Success 3 :: Validation Int Int)
-- [Success 3,Success 6]
instance Bitraversable Validation where
  bitraverse _ g (Success a) =
    Success <$> g a
  bitraverse f _ (Failure e) =
    Failure <$> f e
  {-# INLINE bitraverse #-}

-- | First 'Success' wins; two 'Failure's are combined with '<>'.
--
-- >>> Failure ["e1"] <> Failure ["e2"] :: Validation [String] Int
-- Failure ["e1","e2"]
--
-- >>> Failure ["e1"] <> Success 2 :: Validation [String] Int
-- Success 2
--
-- >>> Success 1 <> Failure ["e2"] :: Validation [String] Int
-- Success 1
--
-- >>> Success 1 <> Success 2 :: Validation [String] Int
-- Success 1
instance (Semigroup e) => Semigroup (Validation e a) where
  Failure e1 <> Failure e2 = Failure (e1 <> e2)
  Failure _ <> Success a = Success a
  Success a <> _ = Success a
  {-# INLINE (<>) #-}

-- |
-- >>> mempty :: Validation [String] Int
-- Failure []
instance (Monoid e) => Monoid (Validation e a) where
  mempty =
    Failure mempty
  {-# INLINE mempty #-}

#if !MIN_VERSION_lens(4,20,0)
instance Swapped Validation where
  swapped = iso swap swap
  {-# INLINE swapped #-}
#endif

-- |
-- >>> import Data.Bifunctor.Swap(Swap(swap))
-- >>> swap (Failure "err" :: Validation String Int)
-- Success "err"
--
-- >>> swap (Success 1 :: Validation String Int)
-- Failure 1
instance Swap Validation where
  swap v =
    case v of
      Failure e -> Success e
      Success a -> Failure a
  {-# INLINE swap #-}

-- |
-- >>> import Control.DeepSeq(rnf)
-- >>> rnf (Success 1 :: Validation String Int)
-- ()
--
-- >>> rnf (Failure "err" :: Validation String Int)
-- ()
instance (NFData e, NFData a) => NFData (Validation e a) where
  rnf v =
    case v of
      Failure e -> rnf e
      Success a -> rnf a
  {-# INLINE rnf #-}

-- | Catamorphism for 'Validation'.
--
-- >>> foldValidation show show (Failure 1 :: Validation Int Int)
-- "1"
--
-- >>> foldValidation show show (Success 2 :: Validation Int Int)
-- "2"
foldValidation :: (a -> x) -> (b -> x) -> Validation a b -> x
foldValidation f _ (Failure a) = f a
foldValidation _ s (Success b) = s b
{-# INLINE foldValidation #-}

-- | Polymorphic 'Prism' targeting the 'Failure' constructor.
--
-- >>> import Control.Lens((^?), review)
-- >>> review __Failure "err" :: Validation String Int
-- Failure "err"
--
-- >>> (Failure "err" :: Validation String Int) ^? __Failure
-- Just "err"
--
-- >>> (Success 1 :: Validation String Int) ^? __Failure
-- Nothing
__Failure :: Prism (Validation a b) (Validation a' b) a a'
__Failure =
  prism
    Failure
    ( \case
        Failure a -> Right a
        Success b -> Left (Success b)
    )
{-# INLINE __Failure #-}

-- | Polymorphic 'Prism' targeting the 'Success' constructor.
--
-- >>> import Control.Lens((^?), review)
-- >>> review __Success 1 :: Validation String Int
-- Success 1
--
-- >>> (Success 1 :: Validation String Int) ^? __Success
-- Just 1
--
-- >>> (Failure "err" :: Validation String Int) ^? __Success
-- Nothing
__Success :: Prism (Validation a b) (Validation a b') b b'
__Success =
  prism
    Success
    ( \case
        Failure a -> Left (Failure a)
        Success b -> Right b
    )
{-# INLINE __Success #-}

-- | Isomorphism between 'Validation' and 'Either'.
--
-- >>> import Control.Lens(view)
-- >>> view either (Failure "err" :: Validation String Int)
-- Left "err"
--
-- >>> view either (Success 1 :: Validation String Int)
-- Right 1
either :: Iso (Validation a b) (Validation a' b') (Either a b) (Either a' b')
either =
  iso
    (foldValidation Left Right)
    (Either.either Failure Success)
{-# INLINE either #-}

-- | Isomorphism between @Validation a a@ and @(Bool, a)@, where 'False' corresponds to 'Failure'.
--
-- >>> import Control.Lens(view)
-- >>> view codiagonal (Failure "x" :: Validation String String)
-- (False,"x")
--
-- >>> view codiagonal (Success "x" :: Validation String String)
-- (True,"x")
codiagonal :: Iso (Validation a a) (Validation a' a') (Bool, a) (Bool, a')
codiagonal =
  iso
    (foldValidation (False,) (True,))
    (\(p, a) -> bool (Failure a) (Success a) p)
{-# INLINE codiagonal #-}

-- | Class for types that have a 'Getter' to a 'Validation'.
class GetValidation s err a | s -> err a where
  getValidation :: Getter s (Validation err a)

instance GetValidation (Validation err a) err a where
  getValidation = id
  {-# INLINE getValidation #-}

-- | Class for types that have a 'Lens'' to a 'Validation' (as generated by @makeClassy@).
class (GetValidation s err a) => HasValidation s err a | s -> err a where
  validation :: Lens' s (Validation err a)

instance HasValidation (Validation err a) err a where
  validation = id
  {-# INLINE validation #-}

-- | Class for types that have a 'Review' to a 'Validation'.
class ReviewValidation s err a | s -> err a where
  reviewValidation :: Review s (Validation err a)

instance ReviewValidation (Validation err a) err a where
  reviewValidation = id
  {-# INLINE reviewValidation #-}

-- | Class for types that have a 'Prism'' to a 'Validation' (as generated by @makeClassyPrisms@).
class (ReviewValidation s err a) => AsValidation s err a | s -> err a where
  _Validation :: Prism' s (Validation err a)

instance AsValidation (Validation err a) err a where
  _Validation = id
  {-# INLINE _Validation #-}

-- | Class for types that have a 'Getter' to an @err@.
class GetFailure s err a | s -> err a where
  getFailure :: Getter s err

-- | Class for types that have a 'Lens'' to an @err@.
class HasFailure s err a | s -> err a where
  failure :: Lens' s err

-- | Class for types that have a 'Review' to construct from an @err@.
class ReviewFailure s err a | s -> err a where
  reviewFailure :: Review s err

-- |
-- >>> import Control.Lens((#))
-- >>> reviewFailure # "err" :: Validation String Int
-- Failure "err"
instance ReviewFailure (Validation err a) err a where
  reviewFailure = __Failure
  {-# INLINE reviewFailure #-}

-- |
-- >>> import Control.Lens((#))
-- >>> reviewFailure # "err" :: Either String Int
-- Left "err"
instance ReviewFailure (Either a b) a b where
  reviewFailure =
    prism'
      Left
      ( \case
          Left a -> Just a
          Right _ -> Nothing
      )
  {-# INLINE reviewFailure #-}

-- | Class for types that have a 'Prism'' to an @err@ (as generated by @makeClassyPrisms@).
class (ReviewFailure s err a) => AsFailure s err a | s -> err a where
  _Failure :: Prism' s err

-- |
-- >>> import Control.Lens((^?), (#))
-- >>> _Failure # "err" :: Validation String Int
-- Failure "err"
--
-- >>> (Failure "err" :: Validation String Int) ^? _Failure
-- Just "err"
--
-- >>> (Success 1 :: Validation String Int) ^? _Failure
-- Nothing
instance AsFailure (Validation err a) err a where
  _Failure = __Failure
  {-# INLINE _Failure #-}

-- |
-- >>> import Control.Lens((^?), (#))
-- >>> _Failure # "err" :: Either String Int
-- Left "err"
--
-- >>> (Left "err" :: Either String Int) ^? _Failure
-- Just "err"
--
-- >>> (Right 1 :: Either String Int) ^? _Failure
-- Nothing
instance AsFailure (Either a b) a b where
  _Failure =
    prism'
      Left
      ( \case
          Left a -> Just a
          Right _ -> Nothing
      )
  {-# INLINE _Failure #-}

-- | Class for types that have a 'Getter' to an @a@.
class GetSuccess s err a | s -> err a where
  getSuccess :: Getter s a

-- | Class for types that have a 'Lens'' to an @a@.
class HasSuccess s err a | s -> err a where
  success :: Lens' s a

-- | Class for types that have a 'Review' to construct from an @a@.
class ReviewSuccess s err a | s -> err a where
  reviewSuccess :: Review s a

-- |
-- >>> import Control.Lens((#))
-- >>> reviewSuccess # 1 :: Either String Int
-- Right 1
instance ReviewSuccess (Either a b) a b where
  reviewSuccess =
    prism'
      Right
      ( \case
          Right a -> Just a
          Left _ -> Nothing
      )
  {-# INLINE reviewSuccess #-}

-- |
-- >>> import Control.Lens((#))
-- >>> reviewSuccess # 1 :: Validation String Int
-- Success 1
instance ReviewSuccess (Validation err a) err a where
  reviewSuccess = __Success
  {-# INLINE reviewSuccess #-}

-- | Class for types that have a 'Prism'' to an @a@ (as generated by @makeClassyPrisms@).
class (ReviewSuccess s err a) => AsSuccess s err a | s -> err a where
  _Success :: Prism' s a

-- |
-- >>> import Control.Lens((^?), (#))
-- >>> _Success # 1 :: Either String Int
-- Right 1
--
-- >>> (Right 1 :: Either String Int) ^? _Success
-- Just 1
--
-- >>> (Left "err" :: Either String Int) ^? _Success
-- Nothing
instance AsSuccess (Either a b) a b where
  _Success =
    prism'
      Right
      ( \case
          Right a -> Just a
          Left _ -> Nothing
      )
  {-# INLINE _Success #-}

-- |
-- >>> import Control.Lens((^?), (#))
-- >>> _Success # 1 :: Validation String Int
-- Success 1
--
-- >>> (Success 1 :: Validation String Int) ^? _Success
-- Just 1
--
-- >>> (Failure "err" :: Validation String Int) ^? _Success
-- Nothing
instance AsSuccess (Validation err a) err a where
  _Success = __Success
  {-# INLINE _Success #-}

-- | A @Validator@ is a profunctor transformer that wraps the output of @p@ in a 'Validation'.
-- @Validator e (->) x a@ is isomorphic to @x -> Validation e a@.
--
-- The 'Semigroupoid' and 'Category' instances compose by short-circuiting on 'Failure'
-- (like monadic bind, not accumulating). Use the 'Applicative' instance to accumulate
-- errors in parallel.
newtype Validator e p x a = Validator (p x (Validation e a))

-- | @Validator@ specialised to @(->)@.
type Validator' e x a = Validator e (->) x a

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> view _Wrapped' (fmap (+1) (Validator (Success . (*2)) :: Validator' String Int Int)) 3
-- Success 7
--
-- >>> view _Wrapped' (fmap (+1) (Validator (\_ -> Failure "err") :: Validator' String Int Int)) 3
-- Failure "err"
instance (Profunctor p) => Functor (Validator e p x) where
  fmap f (Validator p) = Validator (rmap (fmap f) p)
  {-# INLINE fmap #-}

-- | Applies the accumulating 'Validation' '<.>' to both outputs, using 'Arrow' to fan out.
--
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Data.Functor.Apply(Apply((<.>)))
-- >>> let f = Validator (Success . (+1)) :: Validator' [String] Int Int
-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int
-- >>> view _Wrapped' (fmap (*) f <.> g) 3
-- Success 24
--
-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int
-- >>> let g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int
-- >>> view _Wrapped' (fmap (*) f <.> g) 3
-- Failure ["e1","e2"]
instance (Profunctor p, Arrow p, Semigroup e) => Apply (Validator e p x) where
  Validator f <.> Validator g = Validator (arr (uncurry (<.>)) . (f &&& g))
    where
      (&&&) a b = arr (\x -> (x, x)) >>> first a >>> arr (\(a', x) -> (a', x)) >>> swapFirst b
      swapFirst h = arr (\(c, x) -> (x, c)) >>> first h >>> arr (\(b', c) -> (c, b'))
  {-# INLINE (<.>) #-}

-- | 'pure' lifts a value into a successful 'Validator'. '<*>' accumulates errors.
--
-- >>> import Control.Lens(view, _Wrapped')
-- >>> view _Wrapped' (pure 1 :: Validator' String Int Int) 99
-- Success 1
--
-- >>> let f = Validator (Success . (+1)) :: Validator' [String] Int Int
-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int
-- >>> view _Wrapped' ((*) <$> f <*> g) 3
-- Success 24
--
-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int
-- >>> let g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int
-- >>> view _Wrapped' ((*) <$> f <*> g) 3
-- Failure ["e1","e2"]
instance (Profunctor p, Arrow p, Semigroup e) => Applicative (Validator e p x) where
  pure a = Validator (arr (\_ -> Success a))
  {-# INLINE pure #-}
  (<*>) = (<.>)
  {-# INLINE (<*>) #-}

-- | Tries the left, then the right, accumulating errors on two failures.
--
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Data.Functor.Alt(Alt((<!>)))
-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int
-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int
-- >>> view _Wrapped' (f <!> g) 3
-- Success 6
--
-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int
-- >>> let g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int
-- >>> view _Wrapped' (f <!> g) 3
-- Failure ["e1","e2"]
--
-- >>> let f = Validator (Success . (+1)) :: Validator' [String] Int Int
-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int
-- >>> view _Wrapped' (f <!> g) 3
-- Success 4
instance (Profunctor p, Arrow p, Semigroup e) => Alt (Validator e p x) where
  Validator f <!> Validator g = Validator (arr (uncurry (<!>)) . (f &&& g))
    where
      (&&&) a b = arr (\x -> (x, x)) >>> first a >>> arr (\(a', x) -> (a', x)) >>> swapFirst b
      swapFirst h = arr (\(c, x) -> (x, c)) >>> first h >>> arr (\(b', c) -> (c, b'))
  {-# INLINE (<!>) #-}

-- | Skips the second effect on 'Failure'.
--
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Control.Selective(Selective(select))
-- >>> let v = Validator (\x -> Success (if even x then Right x else Left x)) :: Validator' [String] Int (Either Int Int)
-- >>> let f = Validator (\_ -> Success (+10)) :: Validator' [String] Int (Int -> Int)
-- >>> view _Wrapped' (select v f) 4
-- Success 4
--
-- >>> view _Wrapped' (select v f) 3
-- Success 13
instance (Profunctor p, Arrow p, Semigroup e) => Selective (Validator e p x) where
  select (Validator c) (Validator f) = Validator (arr go . (c &&& f))
    where
      go (vc, vf) = case vc of
        Failure e -> Failure e
        Success x -> Either.either (\a -> fmap ($ a) vf) Success x
      (&&&) a b = arr (\x -> (x, x)) >>> first a >>> arr (\(a', x) -> (a', x)) >>> swapFirst b
      swapFirst h = arr (\(c', x) -> (x, c')) >>> first h >>> arr (\(b', c') -> (c', b'))
  {-# INLINE select #-}

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Data.Profunctor(Profunctor(dimap))
-- >>> view _Wrapped' (dimap (+1) (*2) (Validator (Success . (+10)) :: Validator' String Int Int)) 3
-- Success 28
instance (Profunctor p) => Profunctor (Validator e p) where
  dimap f g (Validator p) = Validator (dimap f (fmap g) p)
  {-# INLINE dimap #-}
  lmap f (Validator p) = Validator (lmap f p)
  {-# INLINE lmap #-}
  rmap f (Validator p) = Validator (rmap (fmap f) p)
  {-# INLINE rmap #-}

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Data.Profunctor(Strong(first'))
-- >>> view _Wrapped' (first' (Validator (Success . (+1)) :: Validator' String Int Int)) (3, "x")
-- Success (4,"x")
--
-- >>> view _Wrapped' (first' (Validator (\_ -> Failure "err") :: Validator' String Int Int)) (3, "x")
-- Failure "err"
instance (Strong p) => Strong (Validator e p) where
  first' (Validator p) = Validator (rmap (\(v, c) -> fmap (,c) v) (first' p))
  {-# INLINE first' #-}
  second' (Validator p) = Validator (rmap (\(c, v) -> fmap (c,) v) (second' p))
  {-# INLINE second' #-}

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Data.Profunctor(Choice(left'))
-- >>> view _Wrapped' (left' (Validator (Success . (+1)) :: Validator' String Int Int)) (Left 3)
-- Success (Left 4)
--
-- >>> view _Wrapped' (left' (Validator (Success . (+1)) :: Validator' String Int Int)) (Right "x")
-- Success (Right "x")
--
-- >>> view _Wrapped' (left' (Validator (\_ -> Failure "err") :: Validator' String Int Int)) (Left 3)
-- Failure "err"
instance (Choice p) => Choice (Validator e p) where
  left' (Validator p) = Validator (rmap (Either.either (fmap Left) (Success . Right)) (left' p))
  {-# INLINE left' #-}
  right' (Validator p) = Validator (rmap (Either.either (Success . Left) (fmap Right)) (right' p))
  {-# INLINE right' #-}

-- | Composes by short-circuiting on 'Failure' (does not accumulate errors).
--
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Data.Semigroupoid(Semigroupoid(o))
-- >>> let f = Validator (Success . (+1)) :: Validator' String Int Int
-- >>> let g = Validator (Success . (*2)) :: Validator' String Int Int
-- >>> view _Wrapped' (g `o` f) 3
-- Success 8
--
-- >>> let f = Validator (\_ -> Failure "e1") :: Validator' String Int Int
-- >>> let g = Validator (Success . (*2)) :: Validator' String Int Int
-- >>> view _Wrapped' (g `o` f) 3
-- Failure "e1"
instance (Choice p, Semigroupoid p) => Semigroupoid (Validator e p) where
  Validator g `o` Validator f =
    Validator (rmap (Either.either Failure id) (right' g `o` rmap (foldValidation Left Right) f))
  {-# INLINE o #-}

-- |
-- >>> import Prelude hiding (id)
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Control.Category(id)
-- >>> view _Wrapped' (id :: Validator' String Int Int) 3
-- Success 3
instance (Choice p, Category p) => Category (Validator e p) where
  id = Validator (rmap Success id)
  {-# INLINE id #-}
  Validator g . Validator f =
    Validator (rmap (Either.either Failure id) (right' g . rmap (foldValidation Left Right) f))
  {-# INLINE (.) #-}

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Control.Arrow(Arrow(arr, first))
-- >>> view _Wrapped' (arr (+1) :: Validator' String Int Int) 3
-- Success 4
--
-- >>> view _Wrapped' (first (Validator (Success . (+1)) :: Validator' String Int Int)) (3, "x")
-- Success (4,"x")
instance (ArrowChoice p, Choice p) => Arrow (Validator e p) where
  arr f = Validator (arr (Success . f))
  {-# INLINE arr #-}
  first (Validator f) = Validator (arr (\(v, c) -> fmap (,c) v) . first f)
  {-# INLINE first #-}

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Control.Arrow(ArrowApply(app))
-- >>> view _Wrapped' (app :: Validator' String (Validator' String Int Int, Int) Int) (Validator (Success . (+1)), 3)
-- Success 4
instance (ArrowApply p, ArrowChoice p, Choice p) => ArrowApply (Validator e p) where
  app = Validator (arr (\(Validator f, x) -> (f, x)) >>> app)
  {-# INLINE app #-}

-- |
-- >>> import Control.Lens(view, _Wrapped')
-- >>> import Control.Arrow(ArrowChoice(left))
-- >>> view _Wrapped' (left (Validator (Success . (+1)) :: Validator' String Int Int)) (Left 3 :: Either Int String)
-- Success (Left 4)
--
-- >>> view _Wrapped' (left (Validator (Success . (+1)) :: Validator' String Int Int)) (Right "x" :: Either Int String)
-- Success (Right "x")
--
-- >>> view _Wrapped' (left (Validator (\_ -> Failure "err") :: Validator' String Int Int)) (Left 3 :: Either Int String)
-- Failure "err"
instance (ArrowChoice p, Choice p) => ArrowChoice (Validator e p) where
  left (Validator f) = Validator (arr (Either.either (fmap Left) (Success . Right)) . left f)
  {-# INLINE left #-}
  right (Validator f) = Validator (arr (Either.either (Success . Left) (fmap Right)) . right f)
  {-# INLINE right #-}

-- |
-- >>> import Control.Lens(view, from, _Wrapped')
-- >>> view _Wrapped' (Validator Success :: Validator' String Int Int) 1
-- Success 1
--
-- >>> view _Wrapped' (view (from _Wrapped') (Success . (+1)) :: Validator' String Int Int) 3
-- Success 4
instance Wrapped (Validator e p x a) where
  type Unwrapped (Validator e p x a) = p x (Validation e a)
  _Wrapped' = iso (\(Validator p) -> p) Validator
  {-# INLINE _Wrapped' #-}

instance Rewrapped (Validator e p x a) (Validator e' p' x' a')

-- | Class for types that have a 'Getter' to a 'Validator'.
class GetValidator s e p x a | s -> e p x a where
  getValidator :: Getter s (Validator e p x a)

instance GetValidator (Validator e p x a) e p x a where
  getValidator = id
  {-# INLINE getValidator #-}

-- | Class for types that have a 'Lens'' to a 'Validator' (as generated by @makeClassy@).
class (GetValidator s e p x a) => HasValidator s e p x a | s -> e p x a where
  validator :: Lens' s (Validator e p x a)

instance HasValidator (Validator e p x a) e p x a where
  validator = id
  {-# INLINE validator #-}

-- | Class for types that have a 'Review' to a 'Validator'.
class ReviewValidator s e p x a | s -> e p x a where
  reviewValidator :: Review s (Validator e p x a)

instance ReviewValidator (Validator e p x a) e p x a where
  reviewValidator = id
  {-# INLINE reviewValidator #-}

-- | Class for types that have a 'Prism'' to a 'Validator' (as generated by @makeClassyPrisms@).
class (ReviewValidator s e p x a) => AsValidator s e p x a | s -> e p x a where
  _Validator :: Prism' s (Validator e p x a)

instance AsValidator (Validator e p x a) e p x a where
  _Validator = id
  {-# INLINE _Validator #-}

-- | Isomorphism between @Validator' e () a@ and @Validation e a@, unwrapping by applying to @()@.
--
-- >>> import Control.Lens(view, from, _Wrapped')
-- >>> view unitValidator (Validator (\() -> Success 1) :: Validator' String () Int)
-- Success 1
--
-- >>> view _Wrapped' (view (from unitValidator) (Failure "err" :: Validation String Int)) ()
-- Failure "err"
unitValidator :: Iso (Validator' e () a) (Validator' e' () a') (Validation e a) (Validation e' a')
unitValidator =
  iso
    (\(Validator k) -> k ())
    (Validator . pure)
{-# INLINE unitValidator #-}

-- | Isomorphism between @Validator e Tagged x a@ and @Validation e a@, unwrapping via 'Tagged'.
--
-- >>> import Control.Lens(view)
-- >>> import Data.Tagged(Tagged(..))
-- >>> view taggedValidator (Validator (Tagged (Success 1)) :: Validator String Tagged Int Int)
-- Success 1
--
-- >>> view taggedValidator (Validator (Tagged (Failure "err")) :: Validator String Tagged Int Int)
-- Failure "err"
taggedValidator :: Iso (Validator e Tagged x a) (Validator e' Tagged x a') (Validation e a) (Validation e' a')
taggedValidator =
  iso
    (\(Validator k) -> unTagged k)
    (Validator . Tagged)
{-# INLINE taggedValidator #-}

-- | Isomorphism that swaps the error and success types of a 'Validator' by 'swap'-ping the inner 'Validation'.
--
-- >>> import Control.Lens(view, _Wrapped')
-- >>> let v = Validator (Success . (+1)) :: Validator' String Int Int
-- >>> view _Wrapped' (view swapValidator v) 3
-- Failure 4
--
-- >>> let w = Validator (\_ -> Failure "err") :: Validator' String Int Int
-- >>> view _Wrapped' (view swapValidator w) 3
-- Success "err"
swapValidator :: (Profunctor p, Profunctor p') => Iso (Validator e p x a) (Validator e' p' x' a') (Validator a p x e) (Validator a' p' x' e')
swapValidator =
  iso
    (\(Validator p) -> Validator (rmap swap p))
    (\(Validator p) -> Validator (rmap swap p))
{-# INLINE swapValidator #-}

-- | A newtype wrapping a monomorphic 'Iso' as a two-parameter profunctor.
-- This allows 'Iso'' to be used as the @p@ parameter in 'Validator'.
newtype Iso'' a b = Iso'' (Iso a a b b)

-- | An 'Iso' between a list and a @Validation () (NonEmpty a)@.
-- The empty list maps to @Failure ()@ and a non-empty list maps to @Success@.
--
-- >>> import Control.Lens(view, review)
-- >>> import Data.List.NonEmpty(NonEmpty(..))
-- >>> view nonEmptyListIsoValidator' [1, 2, 3 :: Int]
-- Success (1 :| [2,3])
--
-- >>> view nonEmptyListIsoValidator' ([] :: [Int])
-- Failure ()
--
-- >>> review nonEmptyListIsoValidator' (Success (1 :| [2, 3]))
-- [1,2,3]
--
-- >>> review nonEmptyListIsoValidator' (Failure ())
-- []
nonEmptyListIsoValidator' ::
  Iso
    [a]
    [a']
    (Validation () (NonEmpty a))
    (Validation () (NonEmpty a'))
nonEmptyListIsoValidator' =
  iso
    ( \case
        [] -> Failure ()
        h : t -> Success (h :| t)
    )
    (foldValidation (\() -> []) toList)
{-# INLINE nonEmptyListIsoValidator' #-}

-- | A 'Validator' using 'Iso''' that validates a list is non-empty.
-- The empty list maps to @Failure ()@.
--
-- >>> import Control.Lens(view, review)
-- >>> import Data.List.NonEmpty(NonEmpty(..))
-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator
-- >>> view i [1, 2, 3 :: Int]
-- Success (1 :| [2,3])
--
-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator
-- >>> view i ([] :: [Int])
-- Failure ()
--
-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator
-- >>> review i (Success (1 :| [2, 3]))
-- [1,2,3]
--
-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator
-- >>> review i (Failure ())
-- []
nonEmptyListIsoValidator :: Validator () Iso'' [a] (NonEmpty a)
nonEmptyListIsoValidator =
  Validator
    ( Iso''
        nonEmptyListIsoValidator'
    )

-- | A newtype wrapping a monomorphic 'Prism' as a two-parameter profunctor.
-- This allows 'Prism''' to be used as the @p@ parameter in 'Validator'.
newtype Prism'' a b = Prism'' (Prism a a b b)

-- | A 'Prism' from a list to a @Validation Void (NonEmpty a)@.
-- The empty list does not match (yields 'Nothing'); a non-empty list matches as @Success@.
--
-- >>> import Control.Lens((^?), review)
-- >>> import Data.List.NonEmpty(NonEmpty(..))
-- >>> [1, 2, 3 :: Int] ^? nonEmptyListPrismValidator'
-- Just (Success (1 :| [2,3]))
--
-- >>> ([] :: [Int]) ^? nonEmptyListPrismValidator'
-- Nothing
--
-- >>> review nonEmptyListPrismValidator' (Success (1 :| [2, 3]))
-- [1,2,3]
nonEmptyListPrismValidator' :: Prism [a] [a] (Validation err (NonEmpty a)) (Validation Void (NonEmpty a))
nonEmptyListPrismValidator' =
  prism'
    (foldValidation absurd toList)
    ( \case
        [] -> Nothing
        h : t -> Just (Success (h :| t))
    )
{-# INLINE nonEmptyListPrismValidator' #-}

-- | A 'Validator' using 'Prism''' that validates a list is non-empty.
-- Uses 'Void' as the error type since the 'Prism' encodes partiality via 'Nothing'.
--
-- >>> import Control.Lens((^?), review)
-- >>> import Data.List.NonEmpty(NonEmpty(..))
-- >>> let Validator (Prism'' p) = nonEmptyListPrismValidator
-- >>> [1, 2, 3 :: Int] ^? p
-- Just (Success (1 :| [2,3]))
--
-- >>> let Validator (Prism'' p) = nonEmptyListPrismValidator
-- >>> ([] :: [Int]) ^? p
-- Nothing
--
-- >>> let Validator (Prism'' p) = nonEmptyListPrismValidator
-- >>> review p (Success (1 :| [2, 3]))
-- [1,2,3]
nonEmptyListPrismValidator :: Validator Void Prism'' [a] (NonEmpty a)
nonEmptyListPrismValidator =
  Validator
    (Prism'' nonEmptyListPrismValidator')