PureScript & Haskell Errors

Covered.purs

module Rpd.API.Covered where

data Covered error state =
    Covered (Array error) (Maybe state)


nothing :: forall error state. Covered error state
nothing =
    Covered [] Nothing


uncover :: forall error state. Covered error state -> Array error /\ Maybe state
uncover (Covered errors maybeState) = errors /\ maybeState


notice :: forall error state. error -> Covered error state
notice error = Covered [error] Nothing


cover :: forall error state. state -> Covered error state
cover state = Covered [] $ Just state


-- covered :: forall error state. state -> Covered error state

hoist
    :: forall error state
     . Array error
    -> Covered error state
    -> Covered error state
hoist error (Covered prevErrors maybeState) =
    Covered (prevErrors <> error) maybeState


hoistOne :: forall error state. error -> Covered error state -> Covered error state
hoistOne error (Covered prevErrors maybeState) = Covered (prevErrors `snoc` error) maybeState


coverIn :: forall error state. state -> Covered error state -> Covered error state
coverIn state (Covered errors _) = Covered errors $ Just state


instance functorCovered :: Functor (Covered errors) where
    map f (Covered errors maybeState) = Covered errors $ f <$> maybeState


instance bifunctorCovered :: Bifunctor Covered where
  bimap f g (Covered errors maybeState) = Covered (f <$> errors) (g <$> maybeState)


instance applyCovered :: Apply (Covered errors) where
  apply (Covered errors maybeF) (Covered prevErrors maybeState) =
    Covered (prevErrors <> errors) (maybeF <*> maybeState) -- FIXME: wrong, could not satisfy the law


instance applicativeCovered :: Applicative (Covered errors) where
  pure = cover


instance bindEither :: Bind (Covered errors) where
  bind (Covered errors (Just state)) f = f state
  bind (Covered errors Nothing) _ = Covered errors Nothing


fromEither :: forall error state. Either error state -> Covered error state
fromEither = either notice cover


fromMaybe :: forall error state. Maybe state -> Covered error state
fromMaybe = maybe nothing cover


instance showCovered :: (Show error, Show state) => Show (Covered error state) where
  show (Covered errors maybeState) = "Covered " <> show errors <> " " <> show maybeState


-- coverEither :: forall m errors state error. Monad m => Semigroup errors => Either error state -> Covered errors m state
-- coverEither (Left error) =
--     nothing

Data.Validation.hs

{-# 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(Swapped(..), Iso, iso, from)
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(Show, Maybe(..))


-- | 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

Errors.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}

module Errors2 where


import Prelude
import Control.Monad.Identity


data Error = Error String

data Value = Value Int


data Step m a = Step [Error] (Maybe Value) (m a)


alt (Just x) Nothing = Just x
alt (Just x) (Just x') = Just x'
alt Nothing r = r


instance Functor f => Functor (Step f) where
  fmap f (Step errors x val) =
    Step errors x (f <$> val)
    

instance Applicative f => Applicative (Step f) where 
   pure x = Step [] Nothing (pure x)
   (Step errors x f) <*> (Step errors' x' val) = 
        Step 
          (errors <> errors') 
          (x `alt` x') 
          $ f <*> val
    

instance Monad (Step Maybe) where
  (Step errors x m) >>= k = 
    case m of 
      Just v ->
        case k v of 
          Step errors' x' m' ->
            Step
              (errors <> errors')
              (x `alt` x')  
              m'
      Nothing -> 
         Step 
              errors
              x
              Nothing
              

instance Monad (Step (Either Error)) where
  (Step errors x m) >>= k = 
    case m of 
      Right v ->
        case k v of 
          Step errors' x' m' ->
            Step
              (errors <> errors')
              (x `alt` x')
              m'
      Left err -> 
         Step 
              (errors <> [ err ])
              x
              (Left err)



instance Show Error where
  show (Error err) = show err
               

instance Show a => Show (Step Maybe a) where
   show (Step errors (Just (Value num)) val)
      = 
          "Step " 
              ++ show errors 
              ++ " / has value " 
              ++ show num 
              ++ " / " 
              ++ show val
   show (Step errors Nothing val)
            = "Step " 
               ++ show errors 
               ++ " / has no value " 
               ++ " / " 
               ++ show val
               

instance Show a => Show (Step (Either Error) a) where
   show (Step errors (Just (Value num)) val)
      = 
          "Step " 
              ++ show errors 
              ++ " / has value " 
              ++ show num 
              ++ " / " 
              ++ show val
   show (Step errors Nothing val)
            = "Step " 
               ++ show errors 
               ++ " / has no value " 
               ++ " / " 
               ++ show val


test :: Step Maybe ()
test = do
    _ <- Step [] (Just $ Value 0) (Just "a")
    _ <- Step [] (Just $ Value 1) (Just "b")
    _ <- Step [Error "foo"] (Just $ Value 2) (Just "c")  
    _ <- Step [Error "bar"] (Just $ Value 3) (Just "d")
    _ <- Step [] (Just $ Value 4) (Just "e")
    _ <- Step [] Nothing (Just "f")            
    _ <- Step [] Nothing (Just "g")
    _ <- Step [] Nothing (Just "h")                
    _ <- Step [] (Just $ Value 5) (Just "i")
    _ <- Step [] Nothing (Just "j")                
    _ <- Step [] Nothing (Just "k")
    _ <- Step [] Nothing (Just "l")
    _ <- Step [Error "buz"] Nothing (Just "m")                            
    return ()
    

test2 :: Step Maybe ()
test2 = do
    _ <- Step [] (Just $ Value 0) (Just "a")
    _ <- Step [] Nothing (Just "b")
    _ <- Step [Error "foo"] Nothing (Just "c")  
    _ <- Step [Error "bar"] Nothing (Just "d")
    _ <- Step [] Nothing (Just "e")
    _ <- Step [] Nothing (Just "f")            
    _ <- Step [] Nothing (Just "g")
    _ <- Step [] Nothing (Just "h")                
    _ <- Step [] Nothing (Just "i")
    _ <- Step [] Nothing (Just "j")                
    _ <- Step [] Nothing (Just "k")
    _ <- Step [] Nothing (Just "l")
    _ <- Step [Error "buz"] Nothing (Just "m")                            
    return ()
    

test3 :: Step Maybe ()
test3 = do
    _ <- Step [] Nothing (Just "a")
    _ <- Step [] Nothing (Just "b")
    _ <- Step [Error "foo"] Nothing (Just "c")  
    _ <- Step [Error "bar"] Nothing (Just "d")
    _ <- Step [] Nothing (Just "e")
    _ <- Step [] Nothing (Just "f")            
    _ <- Step [] Nothing (Just "g")
    _ <- Step [] Nothing (Just "h")                
    _ <- Step [] Nothing (Just "i")
    _ <- Step [] Nothing (Just "j")                
    _ <- Step [] Nothing (Just "k")
    _ <- Step [] Nothing (Just "l")
    _ <- Step [Error "buz"] Nothing (Just "m")                            
    return ()
    

push :: Monad m => Value -> Step m ()
push x = 
    Step [] (Just x) (return ())


note :: Either Error x -> Step (Either Error) x
note either = Step [] Nothing either


test4 :: Step (Either Error) ()
test4 = do
    _ <- push (Value 1)
    _ <- Step [] Nothing (Right "b")
    _ <- Step [Error "foo"] (Just (Value 2)) (Right "c")
    _ <- push (Value 3)    
    _ <- note (Left (Error "x"))
    _ <- note (Left (Error "y"))          
    _ <- Step [Error "bar"] Nothing (Right "d")
    _ <- Step [] Nothing (Right "e")
    _ <- Step [] Nothing (Right "f")            
    _ <- Step [] Nothing (Right "g")
    _ <- Step [] Nothing (Right "h")                
    _ <- Step [] Nothing (Right "i")
    _ <- Step [] Nothing (Right "j")                
    _ <- Step [] Nothing (Right "k")
    _ <- Step [] Nothing (Right "l")
    _ <- Step [Error "buz"] Nothing (Right "m")                            
    return ()

Errors.purs

module Rpd.API.Covered
    -- * Errors Monad
    ( Errors
    , runErrors
    -- * Error Reporting Functions
    , err
    , err1
    --, choice
    , recover
    , recover_
    , mapRecover
    , unrecover
    -- ** Hoisting Functions
    , hoistMaybe
    , hoistEither
    , hoistEither1
    -- * Errors Transformer
    , ErrorsT
    , runErrorsT
    ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Array (snoc)
import Data.Tuple.Nested ((/\), type (/\))
import Data.Bifunctor (class Bifunctor)

{- inspired by http://hackage.haskell.org/package/hexpr-0.0.0.0/docs/Control-Monad-Errors.html -}



{-| In many error-checking algorithms, it is desireable to report several
    errors rather than simply terminate on detecting the first error.

    Where 'Either' and 'Error' terminates on the first error, 'Errors' can
    recover at specified points and continue error-checking. Even after a
    recovery, the prior errors are logged. If any errors occured during
    error-checking, this si an error in the whole computation.
-}

import Prelude

import Data.Monoid
import Data.Identity
import Data.Either
import Data.Maybe
import Data.Array ((:))
import Data.Array (singleton) as Array
import Data.Tuple.Nested ((/\), type (/\))
import Data.Traversable (traverse)
import Control.Applicative
import Control.Monad
import Control.Comonad
import Control.Monad.Writer
import Control.Monad.Trans.Class
-- import Control.Monad.Trans.Either hiding (hoistEither)


{-| Shortcut for 'ErrorsT' over the 'Identity' monad. -}
type Errors e = ErrorsT e Identity
{-| Computations that can collect multiple errors. -}
newtype ErrorsT e m a = ErrorsT (m (Maybe e -> (Maybe a /\ Maybe e)))


{-| Perform an error-reporting computation. -}
runErrors :: forall e a. (Monoid e) => Errors e a -> Either e a
runErrors = extract <<< runErrorsT


{-| Perform the error reporting part of a computation. -}
runErrorsT :: forall e m a. Monad m => Monoid e => ErrorsT e m a -> m (Either e a)
runErrorsT (ErrorsT unErrors) = do
    innerAction <- unErrors
    let res = innerAction Nothing
    pure $ case res of
        (Just val /\ Nothing) -> Right val
        (_ /\ Just errs) -> Left errs
        (Nothing /\ Nothing) -> Left mempty


{-| Report an error. -}
err :: forall e m a. Monad m => Monoid e => e -> ErrorsT e m a
err msg = ErrorsT <<< pure $ \e -> (Nothing /\ (e <> Just msg))

{-| Report one error accumulating in a list. -}
err1 :: forall e m a. Monad m => e -> ErrorsT (Array e) m a
err1 = err <<< Array.singleton

{-| Try several alternatives (in order), but if none succeed, raise the passed error. -}
{-
choice :: Monad m => Monoid e => e -> Array (ErrorsT e m a) -> ErrorsT e m a
choice e0 [] = err e0
choice e0 (a : as) = do
    res <- lift $ runErrorsT a
    case res of
        Left e0 -> choice e0 as
        Right val -> pure val
-}

{-| If the action returns an error, relpace the result with a default.
    The error is still logged and reported at the end of the computation. -}
recover :: forall e m a. Monad m => Monoid e => a -> ErrorsT e m a -> ErrorsT e m a
recover replacement action = ErrorsT $ do
    res <- runErrorsT action
    pure $ case res of
        Left err -> \e -> (Just replacement /\ (e <> Just err))
        Right val -> \e -> (Just val /\ e)

{-| As 'recover', but any successful result value does not matter. -}
recover_ :: forall e m a. Monad m => Monoid e => ErrorsT e m a -> ErrorsT e m Unit
recover_ action = recover unit (const unit <$> action)

{-| Perform many error checks, recovering between each. The value at each index of the output
    list corresponds to the index of the input computation list. Error values are 'Nothing'
    in the output, successful values are wrapped in 'Just'. -}
mapRecover :: forall e m a. Monad m => Monoid e => Array (ErrorsT e m a) -> ErrorsT e m (Array (Maybe a))
mapRecover actions = traverse (recover Nothing <<< ((<$>) Just)) actions

{-| If any errors have been detected, cuase them to be loud again. -}
unrecover :: forall m e. Monad m => Monoid e => ErrorsT e m Unit
unrecover = ErrorsT <<< pure $ \e -> case e of
    Nothing -> (Just unit /\ e)
    Just _ -> (Nothing /\ e)

{-| Turn a 'Maybe' computation into an 'ErrorsT' computation. -}
hoistMaybe :: forall e m a. Monad m => Monoid e => e -> Maybe a -> ErrorsT e m a
hoistMaybe e = maybe (err e) pure

{-| Turn an 'Either' computation into an 'ErrorsT' computation. -}
hoistEither :: forall e m a. Monad m => Monoid e => Either e a -> ErrorsT e m a
hoistEither = either err pure

{-| Turn an 'Either' computation into an 'ErrorsT' computation when accumulating a list. -}
hoistEither1 :: forall e m a. Monad m => Either e a -> ErrorsT (Array e) m a
hoistEither1 = either err1 pure


instance functorErrorsT :: (Monad m, Monoid e) => Functor (ErrorsT e m) where
    map f m = m >>= (pure <<< f)

instance applyErrorsT :: (Monad m, Monoid e) => Apply (ErrorsT e m) where
    apply = ap

instance applicativeErrorsT :: (Monad m, Monoid e) => Applicative (ErrorsT e m) where
    pure v = ErrorsT $ pure $ \e -> (Just v /\ e)

instance bindErrorsT :: (Monad m, Monoid e) => Bind (ErrorsT e m) where
    bind x k = ErrorsT $ do
        xRes <- runErrorsT x
        case xRes of
            Left err -> pure $ \e -> (Nothing /\ (e <> Just err))
            Right val -> let (ErrorsT unErrorsY) = k val in unErrorsY
                -- pure $ \e -> yVal
            -- Right val ->  unErrors $ k val
            -- Right val ->  pure $ (\y err -> ?wh $ runErrorsT y) $ k val
            {-
            Right val -> pure $ \e -> do
                yRes <- runErrorsT $ k val
                pure $ case yRes of
                    Left err' -> \e -> (val /\ (e <> Just err'))
                    Right val' -> \e -> (val' /\ e)
            -}

instance monadErrorsT :: (Monad m, Monoid e) => Monad (ErrorsT e m)

instance monadTransErrorsT :: (Monoid e) => MonadTrans (ErrorsT e) where
    lift x = ErrorsT $ do
        x' <- x
        pure $ \e -> (Just x' /\ e)

-- instance (MonadIO m, Monoid e) => MonadIO (ErrorsT e m) where
--     liftIO = lift . liftIO

Tardis.class.hs

{-# OPTIONS_GHC -Wall -fno-warn-warnings-deprecations   #-}
{-# LANGUAGE DoRec                           #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances      #-}


-- | The class definition of a Tardis,
-- as well as a few straightforward combinators
-- based on its primitives.
-- 
-- See Control.Monad.Tardis for the general explanation
-- of what a Tardis is and how to use it.
module Control.Monad.Tardis.Class
  ( -- * The MonadTardis class
    MonadTardis (..)
    -- * Composite Tardis operations
  , modifyForwards
  , modifyBackwards
  , getsPast
  , getsFuture
  ) where

import Control.Applicative
import Control.Monad.Fix

import qualified Control.Monad.Trans.Tardis as T

-- | A Tardis is parameterized by two state streams:
-- a 'backwards-traveling' state and a 'forwards-traveling' state.
-- This library consistently puts the backwards-traveling state first
-- whenever the two are seen together.
-- 
-- Minimal complete definition:
-- ("tardis") or
-- ("getPast", "getFuture", "sendPast", and "sendFuture").
class (Applicative m, MonadFix m) => MonadTardis bw fw m | m -> bw, m -> fw where
  -- | Retrieve the current value of the 'forwards-traveling' state,
  -- which therefore came forwards from the past.
  -- You can think of forwards-traveling state as traveling
  -- 'downwards' through your code.
  getPast    :: m fw
  
  -- | Retrieve the current value of the 'backwards-traveling' state,
  -- which therefore came backwards from the future.
  -- You can think of backwards-traveling state as traveling
  -- 'upwards' through your code.
  getFuture  :: m bw
  
  -- | Set the current value of the 'backwards-traveling' state,
  -- which will therefore be sent backwards to the past.
  -- This value can be retrieved by calls to "getFuture"
  -- located 'above' the current location,
  -- unless it is overwritten by an intervening "sendPast".
  sendPast   :: bw -> m ()
  
  -- | Set the current value of the 'forwards-traveling' state,
  -- which will therefore be sent forwards to the future.
  -- This value can be retrieved by calls to "getPast"
  -- located 'below' the current location,
  -- unless it is overwritten by an intervening "sendFuture".
  sendFuture :: fw -> m ()

  getPast        = tardis $ \ ~(bw, fw)  -> (fw, (bw, fw))
  getFuture      = tardis $ \ ~(bw, fw)  -> (bw, (bw, fw))
  sendPast   bw' = tardis $ \ ~(_bw, fw) -> ((), (bw', fw))
  sendFuture fw' = tardis $ \ ~(bw, _fw) -> ((), (bw, fw'))

  -- | A Tardis is merely a pure state transformation.
  tardis :: ((bw, fw) -> (a, (bw, fw))) -> m a
  tardis f = do
    rec
      let (a, (future', past')) = f (future, past)
      sendPast future'
      past <- getPast
      future <- getFuture
      sendFuture past'
    return a

-- | Modify the forwards-traveling state
-- as it passes through from past to future.
modifyForwards :: MonadTardis bw fw m => (fw -> fw) -> m ()
modifyForwards f = getPast >>= sendFuture . f

-- | Modify the backwards-traveling state
-- as it passes through from future to past.
modifyBackwards :: MonadTardis bw fw m => (bw -> bw) -> m ()
modifyBackwards f = do
  rec
    sendPast (f x)
    x <- getFuture
  return ()

-- | Retrieve a specific view of the forwards-traveling state.
getsPast :: MonadTardis bw fw m => (fw -> a) -> m a
getsPast f = f <$> getPast

-- | Retrieve a specific view of the backwards-traveling state.
getsFuture :: MonadTardis bw fw m => (bw -> a) -> m a
getsFuture f = f <$> getFuture


instance MonadFix m => MonadTardis bw fw (T.TardisT bw fw m) where
  getPast    = T.getPast
  getFuture  = T.getFuture
  sendPast   = T.sendPast
  sendFuture = T.sendFuture
  tardis     = T.tardis

TardisT.hs

{-# OPTIONS_GHC -Wall -fno-warn-warnings-deprecations #-}
{-# LANGUAGE DoRec                           #-}


-- | The data definition of a "TardisT"
-- as well as its primitive operations,
-- and straightforward combinators based on the primitives.
-- 
-- See Control.Monad.Tardis for the general explanation
-- of what a Tardis is and how to use it.
module Control.Monad.Trans.Tardis (
    -- * The Tardis monad transformer
    TardisT (TardisT, runTardisT)
  , evalTardisT
  , execTardisT

    -- * The Tardis monad
  , Tardis
  , runTardis
  , evalTardis
  , execTardis

    -- * Primitive Tardis operations
  , tardis

  , getPast
  , getFuture
  , sendPast
  , sendFuture

    -- * Composite Tardis operations
  , modifyForwards
  , modifyBackwards

  , getsPast
  , getsFuture

    -- * Other
  , mapTardisT
  , noState
  ) where

import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Morph


-- Definition
-------------------------------------------------

-- | A TardisT is parameterized by two state streams:
-- a 'backwards-traveling' state and a 'forwards-traveling' state.
-- This library consistently puts the backwards-traveling state first
-- whenever the two are seen together.
newtype TardisT bw fw m a = TardisT
  { runTardisT :: (bw, fw) -> m (a, (bw, fw))
    -- ^ A TardisT is merely an effectful state transformation
  }

-- | Using a Tardis with no monad underneath
-- will prove to be most common use case.
-- Practical uses of a TardisT require that the
-- underlying monad be an instance of MonadFix,
-- but note that the IO instance of MonadFix
-- is almost certainly unsuitable for use with
-- Tardis code.
type Tardis bw fw = TardisT bw fw Identity

-- | A Tardis is merely a pure state transformation.
runTardis :: Tardis bw fw a -> (bw, fw) -> (a, (bw, fw))
runTardis m = runIdentity . runTardisT m


-- Helpers
-------------------------------------------------

-- | Run a Tardis, and discard the final state,
-- observing only the resultant value.
evalTardisT :: Monad m => TardisT bw fw m a -> (bw, fw) -> m a
evalTardisT t s = fst `liftM` runTardisT t s

-- | Run a Tardis, and discard the resultant value,
-- observing only the final state (of both streams).
-- Note that the 'final' state of the backwards-traveling state
-- is the state it reaches by traveling from the 'bottom'
-- of your code to the 'top'.
execTardisT :: Monad m => TardisT bw fw m a -> (bw, fw) -> m (bw, fw)
execTardisT t s = snd `liftM` runTardisT t s


-- | Run a Tardis, and discard the final state,
-- observing only the resultant value.
evalTardis :: Tardis bw fw a -> (bw, fw) -> a
evalTardis t = runIdentity . evalTardisT t

-- | Run a Tardis, and discard the resultant value,
-- observing only the final state (of both streams).
execTardis :: Tardis bw fw a -> (bw, fw) -> (bw, fw)
execTardis t = runIdentity . execTardisT t


-- | A function that operates on the internal representation of a Tardis
-- can also be used on a Tardis.
mapTardisT :: (m (a, (bw, fw)) -> n (b, (bw, fw)))
           -> TardisT bw fw m a -> TardisT bw fw n b
mapTardisT f m = TardisT $ f . runTardisT m

-- | Some Tardises never observe the 'initial' state
-- of either state stream, so it is convenient
-- to simply hand dummy values to such Tardises.
-- 
-- > noState = (undefined, undefined)
noState :: (a, b)
noState = (undefined, undefined)


-- Instances
-------------------------------------------------

instance MonadFix m => Monad (TardisT bw fw m) where
  return x = tardis $ \s -> (x, s)
  m >>= f  = TardisT $ \ ~(bw, fw) -> do
    rec (x,  ~(bw'', fw' )) <- runTardisT m (bw', fw)
        (x', ~(bw' , fw'')) <- runTardisT (f x) (bw, fw')
    return (x', (bw'', fw''))

instance MonadFix m => Functor (TardisT bw fw m) where
  fmap = liftM

instance MonadFix m => Applicative (TardisT bw fw m) where
  pure = return
  (<*>) = ap


instance MonadTrans (TardisT bw fw) where
  lift m = TardisT $ \s -> do
    x <- m
    return (x, s)

instance MonadFix m => MonadFix (TardisT bw fw m) where
  mfix f = TardisT $ \s -> do
    rec (x, s') <- runTardisT (f x) s
    return (x, s')

instance MFunctor (TardisT bw fw) where
  hoist = mapTardisT

-- Basics
-------------------------------------------------

-- | From a stateful computation, construct a Tardis.
-- This is the pure parallel to the constructor "TardisT",
-- and is polymorphic in the transformed monad.
tardis :: Monad m => ((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis f = TardisT $ \s -> return (f s)

-- | Retrieve the current value of the 'forwards-traveling' state,
-- which therefore came forwards from the past.
-- You can think of forwards-traveling state as traveling
-- 'downwards' through your code.
getPast :: Monad m => TardisT bw fw m fw
getPast = tardis $ \ ~(bw, fw)  -> (fw, (bw, fw))

-- | Retrieve the current value of the 'backwards-traveling' state,
-- which therefore came backwards from the future.
-- You can think of backwards-traveling state as traveling
-- 'upwards' through your code.
getFuture :: Monad m => TardisT bw fw m bw
getFuture = tardis $ \ ~(bw, fw)  -> (bw, (bw, fw))

-- | Set the current value of the 'backwards-traveling' state,
-- which will therefore be sent backwards to the past.
-- This value can be retrieved by calls to "getFuture"
-- located 'above' the current location,
-- unless it is overwritten by an intervening "sendPast".
sendPast :: Monad m => bw -> TardisT bw fw m ()
sendPast bw' = tardis $ \ ~(_bw, fw) -> ((), (bw', fw))

-- | Set the current value of the 'forwards-traveling' state,
-- which will therefore be sent forwards to the future.
-- This value can be retrieved by calls to "getPast"
-- located 'below' the current location,
-- unless it is overwritten by an intervening "sendFuture".
sendFuture :: Monad m => fw -> TardisT bw fw m ()
sendFuture fw' = tardis $ \ ~(bw, _fw) -> ((), (bw, fw'))


-- | Modify the forwards-traveling state
-- as it passes through from past to future.
modifyForwards :: MonadFix m => (fw -> fw) -> TardisT bw fw m ()
modifyForwards f = getPast >>= sendFuture . f

-- | Modify the backwards-traveling state
-- as it passes through from future to past.
modifyBackwards :: MonadFix m => (bw -> bw) -> TardisT bw fw m ()
modifyBackwards f = do
  rec
    sendPast (f x)
    x <- getFuture
  return ()


-- | Retrieve a specific view of the forwards-traveling state.
getsPast :: MonadFix m => (fw -> a) -> TardisT bw fw m a
getsPast f = fmap f getPast


-- | Retrieve a specific view of the backwards-traveling state.
getsFuture :: MonadFix m => (bw -> a) -> TardisT bw fw m a
getsFuture f = fmap f getFuture

ValidateT.hs

{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE UndecidableInstances #-}

-- | __This is an internal module.__ Backwards compatibility will not be maintained. See
-- "Control.Monad.Validate" for the public interface.
module Control.Monad.Validate.Internal where

import Control.Monad.IO.Class
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader.Class
import Control.Monad.State.Strict
import Control.Monad.Trans.Control
import Control.Monad.Writer.Class
import Data.Functor
import Data.Functor.Identity
import Data.Tuple (swap)
import GHC.Stack (HasCallStack)

import Control.Monad.Validate.Class

{-| 'ValidateT' is a monad transformer for writing validations. Like 'ExceptT', 'ValidateT' is
primarily concerned with the production of errors, but it differs from 'ExceptT' in that 'ValidateT'
is designed not to necessarily halt on the first error. Instead, it provides a mechanism for
collecting many warnings or errors, ideally as many as possible, before failing. In that sense,
'ValidateT' is also somewhat like 'Control.Monad.Writer.WriterT', but it is not /just/ a combination
of 'ExceptT' and 'Control.Monad.Writer.WriterT'. Specifically, it differs in the following two
respects:

  1. 'ValidateT' automatically collects errors from all branches of an 'Applicative' expression,
     making it possible to write code in the same style that one would use with 'ExceptT' and
     automatically get additional information for free. (This is especially true when used in
     combination with the @ApplicativeDo@ language extension.)

  2. 'ValidateT' provides error signaling operators, 'refute' and 'dispute', which are similar to
     'throwError' and 'tell', respectively. However, both operators combine raised errors into a
     single value (using an arbitrary 'Semigroup'), so the relative ordering of validation errors is
     properly respected. (Of course, if the order doesn’t matter to you, you can choose to
     accumulate errors into an unordered container.)

== An introduction to 'ValidateT'

The first of the above two points is by far the most interesting feature of 'ValidateT'. Let’s make
it more concrete with an example:

@
>>> 'runValidate' ('refute' ["bang"] '*>' 'refute' ["boom"])
'Left' ["bang", "boom"]
@

At first blush, the above example may lead you to believe that 'refute' is like 'tell' from
'Control.Monad.Writer.WriterT', but it is actually more like 'throwError'. Consider its type:

@
'refute' :: 'MonadValidate' e m => e -> m a
@

Note that, like 'throwError', 'refute' is polymorphic in its return type, which is to say it never
returns. Indeed, if we introduce a dependency on a computation that fails using 'refute' via
'>>=', the downstream computation will not be run:

@
>>> let getString = 'refute' ["bang"] '*>' 'pure' "boom"
        useString a = 'refute' [a]
    in 'runValidate' (getString '>>=' useString)
'Left' ["bang"]
@

This works because although the 'Monad' instance for 'ValidateT' fails as soon as the first 'refute'
is executed (as it must due to the way the second argument of '>>=' depends on the result of its
first argument), the 'Applicative' instance runs all branches of '<*>' and combines the errors
produced by all of them. When @ApplicativeDo@ is enabled, this can lead to some “magical” looking
error reporting where validation automatically continues on each sub-piece of a piece of data until
it absolutely cannot proceed any further. As an example, this package’s test suite includes the
following function:

@
validateQueryRequest :: ('MonadReader' Env m, 'MonadValidate' [Error] m) => Value -> m QueryRequest
validateQueryRequest req = withObject "request" req '$' \o -> do
  qrAuth           <- withKey o "auth_token" parseAuthToken
  ~(qrTable, info) <- withKey o "table" parseTableName
  qrQuery          <- withKey o "query" parseQuery
  'Data.Foldable.for_' info '$' \tableInfo -> pushPath "query" '$'
    validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery
  'pure' QueryRequest { qrAuth, qrTable, qrQuery }
@

The above @do@ block parses and validates some JSON, and it’s written as straight line code, but
with @ApplicativeDo@ enabled (along with the @-foptimal-applicative-do@ option, which makes GHC try
a little harder), it still produces errors for all parts of the input document at once:

@
>>> 'flip' 'Control.Monad.Reader.runReader' env '.' 'runValidateT' '$' validateQueryRequest [aesonQQ|
      { "auth_token": 123
      , "table": { "name": "users" }
      , "query": { "add":
        [ { "lit": "42" }
        , { "select": "points" } ]}
      }|]
'Left' [ Error ["auth_token"] (JSONBadValue "string" (Number 123))
     , Error ["table"] (JSONMissingKey "schema")
     , Error ["query", "add", "lit"] (JSONBadValue "number" (String "42")) ]
@

The penultimate statement in the @do@ block—the one with the call to @validateQuery@—depends on
several of the bindings bound earlier in the same @do@ block, namely @qrAuth@, @info@, and
@qrQuery@. Because of that, @validateQuery@ will not be executed so long as any of its dependencies
fail. As soon as they all succeed, their results will be passed to @validateQuery@ as usual, and
validation will continue.

== The full details

Although 'ValidateT' (with @ApplicativeDo@) may seem magical, of course, it is not. As alluded to
above, 'ValidateT' simply provides a '<*>' implementation that collects errors produced by both
arguments rather than short-circuiting as soon as the first error is raised.

However, that explanation alone may raise some additional questions. What about the monad laws? When
'ValidateT' is used in a monad transformer stack, what happens to side effects? And what are
'ValidateT'’s performance characteristics? The remainder of this section discusses those topics.

=== 'ValidateT' and the 'Monad' laws

'ValidateT'’s 'Applicative' and 'Monad' instances do not conform to a strict interpretation of the
'Monad' laws, which dictate that '<*>' must be equivalent to 'ap'. For 'ValidateT', this is not true
if we consider “equivalent” to mean '=='. However, if we accept a slightly weaker notion of
equivalence, we can satisfy the laws. Specifically, we may use the definition that some 'Validate'
action @a@ is equivalent to another action @b@ iff

  * if @'runValidate' a@ produces @'Right' x@, then @'runValidate' b@ must produce @'Right' y@ where
    @x '==' y@ (and '==' is the usual Haskell '=='),

  * and if @'runValidate' a@ produces @'Left' x@, then @'runValidate' b@ must produce @'Left' y@
    (but @x@ and @y@ may be unrelated).

In other words, our definition of equivalence is like '==', except that we make no guarantees about
the /contents/ of an error should one occur. However, we /do/ guarantee that replacing '<*>' with
'ap' or vice versa will never change an error to a success or a success to an error, nor will it
change the value of a successful result in any way. To put it another way, 'ValidateT' provides
“best effort” error reporting: it will never return fewer errors than an equivalent use of
'ExceptT', but it might return more.

=== Using 'ValidateT' with other monad transformers

'ValidateT' is a valid, lawful, generally well-behaved monad transformer, and it is safe to use
within a larger monad transformer stack. Instances for the most common @mtl@-style typeclasses are
provided. __However__, be warned: many common monad transformers do not have sufficiently
order-independent 'Applicative' instances for 'ValidateT'’s 'Applicative' instance to actually
collect errors from multiple branches of a computation.

To understand why that might be, consider that 'StateT' must enforce a left-to-right evaluation
order for '<*>' in order to thread the state through the computation. If the @a@ action in an
expression @a '<*>' b@ fails, then it is simply not possible to run @b@ since @b@ may still depend
on the state that would have been produced by @a@. Similarly, 'ExceptT' enforces a left-to-right
evaluation because it aborts a computation as soon as an error is thrown. Using 'ValidateT' with
these kinds of monad transformers will cause it to effectively degrade to
'Control.Monad.Writer.WriterT' over 'ExceptT' since it will not be able to gather any errors
produced by 'refute' beyond the first one.

However, even that isn’t the whole story, since the relative order of monads in a monad transformer
stack can affect things further. For example, while the 'StateT' monad transformer enforces
left-to-right evaluation order, it only does this for the monad /underneath/ it, so although
@'StateT' s ('ValidateT' e)@ will not be able to collect multiple errors, @'ValidateT' e
('State' s)@ will. Note, however, that those two types differ in other ways, too—running each to
completion results in different types:

@
'runState' ('runValidateT' m) s :: ('Either' e a, s)
'runValidate' ('runStateT' m s) :: 'Either' e (a, s)
@

That kind of difference is generally true when using monad transformers—the two combinations of
'ExceptT' and 'StateT' have the same types as above, for example—but because 'ValidateT' needs to be
on top of certain transformers for it to be useful, combining 'ValidateT' with certain transformers
may be of little practical use.

One way to identify which monad transformers are uncooperative in the aforementioned way is to look
at the constraints included in the context of the transformer’s 'Applicative' instance. Transformers
like 'Control.Monad.State.StateT' have instances of the shape

@
instance 'Monad' m => 'Applicative' ('StateT' s m)
@

which notably require 'Monad' instances just to implement 'Applicative'! However, this is not always
sufficient for distinguishing which functions or instances use '<*>' and which use '>>=', especially
since many older libraries (which predate 'Applicative') may include 'Monad' contraints even when
they only use features of 'Applicative'. The only way to be certain is to examine the
implementation (or conservatively write code that is explicitly restricted to 'Applicative').

(As it happens, 'ValidateT'’s 'Applicative' is actually one such “uncooperative” instance itself: it
has a 'Monad' constraint in its context. It is possible to write an implementation of 'ValidateT'
without that constraint, but its '<*>' would necessarily leak space in the same way
'Control.Monad.Writer.WriterT'’s '>>=' leaks space. If you have a reason to want the less efficient
but more permissive variant, please let the author of this library know, as she would probably find
it interesting.)

== Performance characteristics of 'ValidateT'

Although the interface to 'ValidateT' is minimal, there are surprisingly many different ways to
implement it, each with its own set of performance tradeoffs. Here is a quick summary of the choices
'ValidateT' makes:

  1. 'ValidateT' is __strict__ in the set of errors it accumulates, which is to say it reduces them
     to weak head normal form (WHNF) via 'seq' immediately upon any call to 'refute' or 'dispute'.

  2. Furthermore, all of 'ValidateT'’s operations, including '<*>', operate in __constant space__.
     This means, for example, that evaluating @'sequence_' xs@ will consume constant space
     regardless of the size of @xs@, not counting any space consumed purely due to the relevant
     'Foldable' instance’s traversal of @xs@.

  3. Finally, 'ValidateT' accumulates errors in a __left-associative__ manner, which is to say that
     any uses of 'refute' or 'dispute' combine the existing set of errors, @e@, with the added set
     of errors, @e'@, via the expression @e '<>' e'@.

A good rule of thumb is that 'ValidateT' has similar performance characteristics to
@'Data.Foldable.foldl'' ('<>')@, while types like @Validation@ from the @either@ package tend to
have similar performance characteristics to @'foldr' ('<>')@. That decision has both significant
advantages and significant disadvantages; the following subsections elaborate further.

=== '<*>' takes constant space

Great care has been taken in the implementation of '<*>' to ensure it does not leak space. Notably,
the same /cannot/ be said for many existing implementations of similar concepts. For example, you
will find that executing the expression

@
let m () = 'pure' () '*>' m () in m ()
@

may continuously allocate memory until it is exhausted for types such as @Validation@ (from the
@either@ package), but 'ValidateT' will execute it in constant space. This point may seem silly,
since the above definition of @m ()@ will never do anything useful, anyway, but the same point also
applies to operations like 'sequence_'.

In practice, this issue matters far less for types like @Validation@ than it does for 'ValidateT',
as @Validation@ and its cousins don’t have a 'Monad' instance and do not generally experience the
same usage patterns. (The additional laziness they are capable of can sometimes even avoid the space
leak altogether.) However, it can be relevant more often for 'ValidateT', so this implementation
makes choices to avoid the potential for the leak altogether.

=== Errors are accumulated using strict, left-associated '<>'

A major consequence of the decision to both strictly accumulate state and maintain constant space is
that 'ValidateT'’s internal applications of '<>' to combine errors are naturally strict and
left-associated, not lazy and right-associated like they are for types like @Validation@. If the
number of errors your validation generates is small, this difference is irrelevant, but if it is
large, the difference in association can prove disastrous if the 'Semigroup' you choose to
accumulate errors in is @[a]@!

To make it painfully explicit why using @[a]@ can come back to bite you, consider that each time
'ValidateT' executes @'refute' e'@, given some existing collection of errors @e@, it (strictly)
evalutes @e '<>' e'@ to obtain a new collection of errors. Now consider the implications of that
if @e@ is a ten thousand element list: '<>' will have to traverse /all/ ten thousand elements and
reallocate a fresh cons cell for every single one in order to build the new list, even if just one
element is being appended to the end! Unfortunately, the ubiquitous, built-in @[a]@ type is clearly
an exceptionally poor choice for this pattern of accumulation.

Fortunately, the solution is quite simple: use a different data structure. If order doesn’t matter,
use a @Set@ or @HashSet@. If it does, but either LIFO consumption of the data is okay or you are
okay with paying to reverse the data once after collecting the errors, use @'Data.Semigroup.Dual'
[a]@ to accumulate elements in an efficient manner. If neither is true, use a data structure like
@Seq@ that provides an efficient implementation of a functional queue. You can always convert back
to a plain list at the end once you’re done, if you have to. -}
newtype ValidateT e m a = ValidateT
  { getValidateT :: forall s. StateT (MonoMaybe s e) (ExceptT e m) a }
-- Sadly, GeneralizedNewtypeDeriving can’t help us here due to the inner forall, but we can at least
-- derive the Functor instance.
deriving instance (Functor m) => Functor (ValidateT e m)

validateT
  :: forall e m a. (Functor m)
  => (forall s. MonoMaybe s e -> m (Either e (MonoMaybe s e, a)))
  -> ValidateT e m a
validateT f = ValidateT (StateT (ExceptT . (fmap (fmap swap) . f)))
{-# INLINE validateT #-}

unValidateT
  :: forall s e m a. (Functor m)
  => MonoMaybe s e -> ValidateT e m a -> m (Either e (MonoMaybe s e, a))
unValidateT e (ValidateT m) = runExceptT (swap <$> runStateT m e)
{-# INLINE unValidateT #-}

instance (Monad m) => Applicative (ValidateT e m) where
  pure v = ValidateT (pure v)
  {-# INLINE pure #-}

  m1 <*> m2 = validateT $ \e0 ->
    unValidateT e0 m1 >>= \case
      Left e1 -> unValidateT (MJust @'SJust e1) m2 <&> \case
        Left e2 -> Left e2
        Right (MJust e2, _) -> Left e2
      Right (e1, v1) -> unValidateT e1 m2 <&> \case
        Left e2 -> Left e2
        Right (e2, v2) -> Right (e2, v1 v2)
  {-# INLINABLE (<*>) #-}

instance (Monad m) => Monad (ValidateT e m) where
  ValidateT x >>= f = ValidateT (x >>= (getValidateT . f))
  {-# INLINE (>>=) #-}

instance MonadTrans (ValidateT e) where
  lift m = ValidateT (lift $ lift m)
  {-# INLINE lift #-}

instance (MonadIO m) => MonadIO (ValidateT e m) where
  liftIO = lift . liftIO
  {-# INLINE liftIO #-}

instance (MonadBase b m) => MonadBase b (ValidateT e m) where
  liftBase = lift . liftBase
  {-# INLINE liftBase #-}

-- | An opaque type used to capture the current state of a 'ValidateT' computation, used as the
-- 'StT' instance for 'ValidateT'. It is opaque in an attempt to protect internal invariants about
-- the state, but it is unfortunately still theoretically possible for it to be misused (but such
-- misuses are exceedingly unlikely).
data ValidateTState e a = forall s. ValidateTState
  { getValidateTState :: Either e (MonoMaybe s e, a) }
deriving instance (Show e, Show a) => Show (ValidateTState e a)
deriving instance Functor (ValidateTState e)

instance MonadTransControl (ValidateT e) where
  type StT (ValidateT e) a = ValidateTState e a

  liftWith f = validateT $ \e ->
    Right . (e,) <$> f (fmap ValidateTState . unValidateT e)
  {-# INLINABLE liftWith #-}

  restoreT :: (HasCallStack, Monad m) => m (StT (ValidateT e) a) -> ValidateT e m a
  restoreT m = validateT $ \e1 -> do
    ValidateTState r <- m
    case e1 of
      MNothing -> case r of
        Left e2             -> pure $ Left e2
        Right (MJust e2, v) -> pure $ Right (MJust e2, v)
        Right (MNothing, v) -> pure $ Right (MNothing, v)
      MJust _ -> case r of
        Left e2             -> pure $ Left e2
        Right (MJust e2, v) -> pure $ Right (MJust e2, v)
        Right (MNothing, _) -> error
          $  "Control.Monad.Validate.ValidateT#restoreT: panic!\n"
          <> "  An attempt was made to restore from a state captured before any validation\n"
          <> "  errors occurred into a context with validation errors. This is probably the\n"
          <> "  result of an incorrect use of MonadBaseControl (as validation errors should\n"
          <> "  strictly increase). Ensure that all state is restored immediately upon\n"
          <> "  returning from the base monad (or is not restored at all).\n"
          <> "\n"
          <> "  If you believe your use of MonadBaseControl is not in error, and this is a bug\n"
          <> "  in ValidateT, please submit a bug report."
  {-# INLINABLE restoreT #-}

instance (MonadBaseControl b m) => MonadBaseControl b (ValidateT e m) where
  type StM (ValidateT e m) a = ComposeSt (ValidateT e) m a
  liftBaseWith = defaultLiftBaseWith
  restoreM = defaultRestoreM
  {-# INLINE liftBaseWith #-}
  {-# INLINE restoreM #-}

liftCatch
  :: (Functor m)
  => (forall b. m b -> (e -> m b) -> m b)
  -> ValidateT d m a -> (e -> ValidateT d m a) -> ValidateT d m a
liftCatch catchE m f = validateT $ \e ->
  catchE (unValidateT e m) (unValidateT e . f)
{-# INLINE liftCatch #-}

instance (MonadError e m) => MonadError e (ValidateT a m) where
  throwError = lift . throwError
  catchError = liftCatch catchError
  {-# INLINE throwError #-}
  {-# INLINE catchError #-}

instance (MonadReader r m) => MonadReader r (ValidateT e m) where
  ask = lift ask
  local f (ValidateT m) = ValidateT (local f m)
  reader = lift . reader
  {-# INLINE ask #-}
  {-# INLINE local #-}
  {-# INLINE reader #-}

instance (MonadState s m) => MonadState s (ValidateT e m) where
  get = lift get
  put = lift . put
  state = lift . state
  {-# INLINE get #-}
  {-# INLINE put #-}
  {-# INLINE state #-}

instance (MonadWriter w m) => MonadWriter w (ValidateT e m) where
  writer = lift . writer
  tell = lift . tell
  listen (ValidateT m) = ValidateT (listen m)
  pass (ValidateT m) = ValidateT (pass m)
  {-# INLINE writer #-}
  {-# INLINE tell #-}
  {-# INLINE listen #-}
  {-# INLINE pass #-}

instance (MonadThrow m) => MonadThrow (ValidateT e m) where
  throwM = lift . throwM
  {-# INLINE throwM #-}

instance (MonadCatch m) => MonadCatch (ValidateT e m) where
  catch = liftCatch catch
  {-# INLINE catch #-}

liftMask
  :: (Functor m)
  => (forall c. ((forall a. m a -> m a) -> m c) -> m c)
  -> ((forall a. ValidateT e m a -> ValidateT e m a) -> ValidateT e m b) -> ValidateT e m b
liftMask maskE f = validateT $ \e1 ->
  maskE $ \unmask ->
    unValidateT e1 $ f $ \m ->
      validateT $ \e2 ->
        unmask $ unValidateT e2 m
{-# INLINE liftMask #-}

instance (MonadMask m) => MonadMask (ValidateT e m) where
  mask = liftMask mask
  uninterruptibleMask = liftMask uninterruptibleMask
  generalBracket m f g = ValidateT $ generalBracket
    (getValidateT m)
    (\a b -> getValidateT $ f a b)
    (\a -> getValidateT $ g a)
  {-# INLINE mask #-}
  {-# INLINE uninterruptibleMask #-}
  {-# INLINE generalBracket #-}

instance (Monad m, Semigroup e) => MonadValidate e (ValidateT e m) where
  refute e2 = validateT $ \e1 ->
    let !e3 = monoMaybe e2 (<> e2) e1 in pure (Left e3)
  dispute e2 = validateT $ \e1 ->
    let !e3 = monoMaybe e2 (<> e2) e1 in pure (Right (MJust e3, ()))
  tolerate m = validateT $ \e1 ->
    Right . either (\e2 -> (MJust e2, Nothing)) (fmap Just) <$> unValidateT e1 m
  {-# INLINABLE refute #-}
  {-# INLINABLE dispute #-}
  {-# INLINABLE tolerate #-}

-- | Runs a 'ValidateT' computation, returning the errors raised by 'refute' or 'dispute' if any,
-- otherwise returning the computation’s result.
runValidateT :: forall e m a. (Functor m) => ValidateT e m a -> m (Either e a)
runValidateT m = unValidateT MNothing m <&> \case
  Left e              -> Left e
  Right (MJust e, _)  -> Left e
  Right (MNothing, v) -> Right v

-- | Runs a 'ValidateT' computation, returning the errors on failure or 'mempty' on success. The
-- computation’s result, if any, is discarded.
--
-- @
-- >>> 'execValidate' ('refute' ["bang"])
-- ["bang"]
-- >>> 'execValidate' @[] ('pure' 42)
-- []
-- @
execValidateT :: forall e m a. (Monoid e, Functor m) => ValidateT e m a -> m e
execValidateT = fmap (either id mempty) . runValidateT

{-| Runs a 'ValidateT' transformer by interpreting it in an underlying transformer with a
'MonadValidate' instance. That might seem like a strange thing to do, but it can be useful in
combination with 'mapErrors' to locally alter the error type in a larger 'ValidateT' computation.
For example:

@
throwsIntegers :: 'MonadValidate' ['Integer'] m => m ()
throwsIntegers = 'dispute' [42]

throwsBools :: 'MonadValidate' ['Bool'] m => m ()
throwsBools = 'dispute' ['False']

throwsBoth :: 'MonadValidate' ['Either' 'Integer' 'Bool'] m => m ()
throwsBoth = do
  'embedValidateT' '$' 'mapErrors' ('map' 'Left') throwsIntegers
  'embedValidateT' '$' 'mapErrors' ('map' 'Right') throwsBools

>>> 'runValidate' throwsBoth
'Left' ['Left' 42, 'Right' False]
@

@since 1.1.0.0 -}
embedValidateT :: forall e m a. (MonadValidate e m) => ValidateT e m a -> m a
embedValidateT m = unValidateT MNothing m >>= \case
  Left e              -> refute e
  Right (MJust e, v)  -> dispute e $> v
  Right (MNothing, v) -> pure v

-- | Applies a function to all validation errors produced by a 'ValidateT' computation.
--
-- @
-- >>> 'runValidate' '$' 'mapErrors' ('map' 'show') ('refute' [11, 42])
-- 'Left' ["11", "42"]
-- @
--
-- @since 1.1.0.0
mapErrors
  :: forall e1 e2 m a. (Monad m, Semigroup e2)
  => (e1 -> e2) -> ValidateT e1 m a -> ValidateT e2 m a
mapErrors f m = lift (unValidateT MNothing m) >>= \case
  Left e              -> refute (f e)
  Right (MJust e, v)  -> dispute (f e) $> v
  Right (MNothing, v) -> pure v

{-| Runs a 'ValidateT' computation, and if it raised any errors, re-raises them using 'throwError'.
This effectively converts a computation that uses 'ValidateT' (or 'MonadValidate') into one that
uses 'MonadError'.

@
>>> 'runExcept' '$' 'validateToError' ('pure' 42)
'Right' 42
>>> 'runExcept' '$' 'validateToError' ('refute' ["boom"] *> 'refute' ["bang"])
'Left' ["boom", "bang"]
@

@since 1.2.0.0 -}
validateToError :: forall e m a. (MonadError e m) => ValidateT e m a -> m a
validateToError = validateToErrorWith id
{-# INLINE validateToError #-}

{-| Like 'validateToError', but additionally accepts a function, which is applied to the errors
raised by 'ValidateT' before passing them to 'throwError'. This can be useful to concatenate
multiple errors into one.

@
>>> 'runExcept' '$' 'validateToErrorWith' 'mconcat' ('pure' 42)
'Right' 42
>>> 'runExcept' '$' 'validateToErrorWith' 'mconcat' ('refute' ["boom"] *> 'refute' ["bang"])
'Left' "boombang"
@

@since 1.2.0.0 -}
validateToErrorWith :: forall e1 e2 m a. (MonadError e2 m) => (e1 -> e2) -> ValidateT e1 m a -> m a
validateToErrorWith f = either (throwError . f) pure <=< runValidateT
{-# INLINE validateToErrorWith #-}

-- | 'ValidateT' specialized to the 'Identity' base monad. See 'ValidateT' for usage information.
type Validate e = ValidateT e Identity

-- | See 'runValidateT'.
runValidate :: forall e a. Validate e a -> Either e a
runValidate = runIdentity . runValidateT
{-# INLINE runValidate #-}

-- | See 'execValidateT'.
execValidate :: forall e a. (Monoid e) => Validate e a -> e
execValidate = runIdentity . execValidateT
{-# INLINE execValidate #-}

{-| Monotonically increasing 'Maybe' values. A function with the type

@
forall s. 'MonoMaybe' s Foo -> 'MonoMaybe' s Bar
@

may return 'MNothing' only when given 'MNothing', but it may return 'MJust' for any input. This
is useful for keeping track of the error state within 'ValidateT', since we want to statically
prevent the possibility of a 'ValidateT' action being passed a nonempty set of errors but returning
no errors.

The benefit of this additional type tracking shows up most prominently in the implementation of
'<*>'. Consider an expression @x '<*>' y@, where @x@ is an action that fails, but @y@ is an action
that succeeds. We pass the errors returned by @x@ to @y@, then pattern-match on @y@’s result. If @y@
succeeds, we’ll end up with a tuple of type @('MonoMaybe' ''SJust' e, a)@. We can’t use the second
element of that tuple at all because we need to return a value of type @b@, but the only way to get
one is to apply a function of type @a -> b@ returned by @x@… which we don’t have, since @x@ failed.

Since we can’t produce a value of type @'Right' b@, our only option is to return a value of type
@'Left' e@. But if the first element of the tuple had type @'Maybe' e@, we’d now be in a sticky
situation! Its value could be 'Nothing', but we need it to be @'Just' e@ since we only have a
'Semigroup' instance for @e@, not a 'Monoid' instance, so we can’t produce an @e@ out of thin air.
However, by returning a 'MonoMaybe', we guarantee that the result will be @'MJust' e@, and we can
proceed safely.
-}
data MonoMaybe s a where
  MNothing :: MonoMaybe 'SMaybe a
  MJust :: forall s a. !a -> MonoMaybe s a
deriving instance (Show a) => Show (MonoMaybe s a)
deriving instance (Eq a) => Eq (MonoMaybe s a)
deriving instance (Ord a) => Ord (MonoMaybe s a)
deriving instance Functor (MonoMaybe s)

-- | The kind of types used to track the current state of a 'MonoMaybe' value.
data MonoMaybeS = SMaybe | SJust

-- | Like 'maybe' but for 'MonoMaybe'.
monoMaybe :: (s ~ 'SMaybe => b) -> (a -> b) -> MonoMaybe s a -> b
monoMaybe v f = \case
  MNothing -> v
  MJust x  -> f x
{-# INLINE monoMaybe #-}

Validation.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Control.Monad.Validation where

import Control.Lens hiding ((.=))
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.State.Strict
import Control.Monad.Trans.Lift.Local
import Data.Aeson
import Data.Foldable as F
import Data.List as L
import Data.Map.Strict as M
import Data.Monoid
import Data.Text as T
import Data.Vector as V
import Test.QuickCheck

-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
-- through ExceptT to single value using Monoid
--  FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
newtype ValidationT e m a = ValidationT
  { unValidationT :: ExceptT e (StateT e m) a
  } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
             , MonadBase b )

instance MonadTrans (ValidationT e) where
  lift = ValidationT . lift . lift

instance LiftLocal (ValidationT e) where
  liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT

-- | Map with 'Monoid' instance which 'mappend' its values
newtype MonoidMap k v = MonoidMap (Map k v)
  deriving (Eq, Ord, Show, Arbitrary)

makePrisms ''MonoidMap

type instance IxValue (MonoidMap k v) = v
type instance Index (MonoidMap k v) = k
instance (Ord k) => Ixed (MonoidMap k v) where
  ix key = _MonoidMap . ix key
instance (Ord k) => At (MonoidMap k v) where
  at key = _MonoidMap . at key

#if MIN_VERSION_base(4,11,0)
instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
  (<>) = mmAppend
#endif

instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
  mempty = MonoidMap M.empty
  mappend = mmAppend

instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
  toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
    where
      toObj (k, v) = object
        [ "id" .= k
        , "value" .= v ]

instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
  parseJSON v = withArray "MonoidMap" go v
    where
      go arr = do
        keyvals <- traverse fromObj arr
        return $ MonoidMap $ M.fromList $ V.toList keyvals
      fromObj objV = flip (withObject "element of MonoidMap") objV $ \obj -> do
        key <- obj .: "id"
        val <- obj .: "value"
        return (key, val)

#if MIN_VERSION_base(4,11,0)
mmAppend :: (Ord k, Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
#else
mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
#endif
mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b

-- | Convenient for 'vZoom' as first artument. Will prevent generation
-- of map with 'mempty' values
mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k

-- | Set given value to 'mempty'
setMempty :: (Monoid s) => ASetter' s a -> a -> s
setMempty setter a = set setter a mempty

memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
memptyWrap b f a
  | a == mempty = b
  | otherwise = f a

-- | If given container is not 'mempty', then use given function to
-- append all its elements and return 'Just' result
neConcat
  :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
  => (a -> a -> a)
  -> f a
  -> Maybe a
neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)

textErrors :: [Text] -> Maybe Text
textErrors = neConcat (\a b -> a <> ", " <> b)

-- | Returns `mempty` instead of error if no warnings was occured. So, your
-- error should have `Eq` instance to detect that any error was occured. Returns
-- Nothing for second element of tuple if compuration was interruped by 'vError'
runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
runValidationT (ValidationT m) = do
  (res, warnings) <- runStateT (runExceptT m) mempty
  return $ case res of
    Left err -> (err <> warnings, Nothing)
    Right a  -> (warnings, Just a)

runValidationTEither
  :: (Monoid e, Eq e, Monad m)
  => ValidationT e m a
  -> m (Either e a)
runValidationTEither action = do
  (err, res) <- runValidationT action
  return $ case res of
    Just a | err == mempty -> Right a
    _                      -> Left err

handleValidationT
  :: (Monoid e, Monad m, Eq e)
  => (e -> m a)
  -> ValidationT e m a
  -> m a
handleValidationT handler action = do
  runValidationTEither action >>= either handler return

-- | Stops further execution of validation
vError :: (Monad m) => e -> ValidationT e m a
vError e = ValidationT $ throwError e

-- | Does not stop further execution, append warning to
vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
vWarning e = ValidationT $ modify' (<> e)

vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
vErrorL l a = vError $ setMempty l a

vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
vWarningL l a = vWarning $ setMempty l a

vZoom
  :: (Monad m, Monoid a, Monoid b)
  => (a -> b)
  -> ValidationT a m x
  -> ValidationT b m x
vZoom up action = do
  (err, res) <- lift $ runValidationT action
  case res of
    Nothing -> vError $ up err
    Just a  -> vWarning (up err) *> return a

vZoomL
  :: (Monad m, Monoid a, Monoid b)
  => ASetter' b a
  -> ValidationT a m x
  -> ValidationT b m x
vZoomL l action = vZoom (setMempty l) action

Validation2.hs

{-# LANGUAGE Rank2Types #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Either.Validation
-- Copyright   :  (c) 2014 Chris Allen, Edward Kmett
-- License     :  BSD-style
--
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Monoidal 'Validation' sibling to 'Either'.
--
-----------------------------------------------------------------------------

module Data.Either.Validation
  ( Validation(..)
  , _Success
  , _Failure
  , eitherToValidation
  , validationToEither
  , _Validation
  , vap
  , ealt
  -- combinators that leak less, but require monoid constraints
  , vapm, apm
  ) where

import Control.Applicative
import Data.Bifoldable(Bifoldable(bifoldr))
import Data.Bifunctor(Bifunctor(bimap))
import Data.Bitraversable(Bitraversable(bitraverse))
import Data.Foldable (Foldable(foldr))
import Data.Functor.Alt (Alt((<!>)))
import Data.Functor.Apply (Apply ((<.>)))
import Data.Monoid (Monoid(mappend, mempty))
import Data.Profunctor
import Data.Semigroup (Semigroup((<>)))
import Data.Traversable (Traversable(traverse))
import Prelude hiding (foldr)

-- | 'Validation' is 'Either' with a Left that is a 'Monoid'
data Validation e a
  = Failure e
  | Success a
  deriving (Eq, Ord, Show)

instance Functor (Validation e) where
   fmap _ (Failure e) = Failure e
   fmap f (Success a) = Success (f a)

instance Semigroup e => Apply (Validation e) where
  Failure e1 <.> b = Failure $ case b of
    Failure e2 -> e1 <> e2
    Success _  -> e1
  Success _  <.> Failure e  = Failure  e
  Success f  <.> Success x  = Success (f x)

instance Semigroup e => Applicative (Validation e) where
  pure = Success
  (<*>) = (<.>)

-- | For two errors, this instance reports both of them.
instance Semigroup e => Alt (Validation e) where
  s@Success{} <!> _ = s
  _ <!> s@Success{} = s
  Failure m <!> Failure n = Failure (m <> n)

instance (Semigroup e, Monoid e) => Alternative (Validation e) where
  empty = Failure mempty
  (<|>) = (<!>)

instance Foldable (Validation e) where
  foldr f x (Success a) = f a x
  foldr _ x (Failure _) = x

instance Traversable (Validation e) where
  traverse f (Success a) = Success <$> f a
  traverse _ (Failure e) = pure (Failure e)

instance Bifunctor Validation where
  bimap f _ (Failure e) = Failure (f e)
  bimap _ g (Success a) = Success (g a)

instance Bifoldable Validation where
  bifoldr _ g x (Success a) = g a x
  bifoldr f _ x (Failure e) = f e x

instance Bitraversable Validation where
  bitraverse _ g (Success a) = Success <$> g a
  bitraverse f _ (Failure e) = Failure <$> f e

instance Semigroup e => Semigroup (Validation e a) where
  x@Success{} <> _ = x
  _ <> x@Success{} = x
  Failure e1 <> Failure e2 = Failure (e1 <> e2)

instance Monoid e => Monoid (Validation e a) where
  mempty = Failure mempty
  x@Success{} `mappend` _ = x
  _ `mappend` x@Success{} = x
  Failure e1 `mappend` Failure e2 = Failure (e1 `mappend` e2)

type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (fmap bt)) . right'
{-# INLINE prism #-}

_Failure :: Prism (Validation a c) (Validation b c) a b
_Failure = prism
           (\ x -> Failure x)
           (\ x
            -> case x of
              Failure y -> Right y
              Success y -> Left (Success y))
{-# INLINE _Failure #-}

_Success :: Prism (Validation c a) (Validation c b) a b
_Success = prism
           (\ x -> Success x)
           (\ x
            -> case x of
              Failure y -> Left (Failure y)
              Success y -> Right y)
{-# INLINE _Success #-}

type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso sa bt = dimap sa (fmap bt)
{-# INLINE iso #-}

validationToEither :: Validation e a -> Either e a
validationToEither x = case x of
  Failure e -> Left e
  Success a -> Right a
{-# INLINE validationToEither #-}

eitherToValidation :: Either e a -> Validation e a
eitherToValidation x = case x of
  Left e -> Failure e
  Right a -> Success a
{-# INLINE eitherToValidation #-}

-- | 'Validation' is isomorphic to 'Either'
_Validation :: Iso (Validation e a) (Validation g b) (Either e a) (Either g b)
_Validation = iso validationToEither eitherToValidation
{-# INLINE _Validation #-}

vap :: Semigroup m => Either m (a -> b) -> Either m a -> Either m b
vap (Left m) b = Left $ case b of
  Left n  -> m <> n
  Right{} -> m
vap Right{} (Left n) = Left n
vap (Right f) (Right a) = Right (f a)
{-# INLINE vap #-}

apm :: Monoid m => Validation m (a -> b) -> Validation m a -> Validation m b
apm (Failure m) b = Failure $ m `mappend` case b of
  Failure n  -> n
  Success{} -> mempty
apm Success{} (Failure n) = Failure n
apm (Success f) (Success a) = Success (f a)
{-# INLINE apm #-}

-- lazier version of vap that can leak less, but which requires a Monoid
vapm :: Monoid m => Either m (a -> b) -> Either m a -> Either m b
vapm (Left m) b = Left $ m `mappend` case b of
  Left n  -> n
  Right{} -> mempty
vapm Right{} (Left n) = Left n
vapm (Right f) (Right a) = Right (f a)
{-# INLINE vapm #-}

ealt :: Validation e a -> Validation e a -> Validation e a
ealt Failure{} r = r
ealt (Success a) _ = Success a
{-# INLINE ealt #-}