Add ValidationT

either.cabal

@@ -51,6 +51,7 @@ library
   exposed-modules:
     Data.Either.Combinators
     Data.Either.Validation
+    Data.Either.ValidationT
 
 test-suite tests
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
@@ -62,5 +63,7 @@ test-suite tests
     either,
     test-framework             >= 0.8.1.1 && < 0.9,
     test-framework-quickcheck2 >= 0.3.0.3 && < 0.4,
+    test-framework-hunit,
+    HUnit,
     QuickCheck                 >= 2.9     && < 2.13
   default-language: Haskell2010

src/Data/Either/ValidationT.hs

@@ -0,0 +1,64 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Either.ValidationT
+-- Copyright   :  (c) 2019 Chris Allen, Edward Kmett, Kostiantyn Rybnikov
+-- License     :  BSD-style
+--
+-- Maintainer  :  ekmett@gmail.com
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Transformer version of 'Validation'. Similar to ExceptT, but
+-- accumulates errors instead of exiting early with the first one.
+--
+-----------------------------------------------------------------------------
+module Data.Either.ValidationT
+  ( ValidationT(..)
+  , runValidationT
+  ) where
+
+import Data.Either.Validation
+
+-- | 'ValidationT' is 'Either' with a Left that is a 'Monoid'
+newtype ValidationT e m a =
+  ValidationT (m (Validation e a))
+
+-- | The inverse of 'ValidationT'.
+runValidationT :: ValidationT e m a -> m (Validation e a)
+runValidationT (ValidationT m) = m
+
+{-# INLINE runValidationT #-}
+instance (Functor m) => Functor (ValidationT e m) where
+  fmap f = ValidationT . fmap (fmap f) . runValidationT
+  {-# INLINE fmap #-}
+
+instance (Semigroup e, Functor m, Monad m) =>
+         Applicative (ValidationT e m) where
+  pure a = ValidationT $ return (Success a)
+  {-# INLINE pure #-}
+  ValidationT f <*> ValidationT v =
+    ValidationT $ do
+      mf <- f
+      case mf of
+        Failure e -> do
+          mv <- v
+          case mv of
+            Failure e2 -> return (Failure (e <> e2))
+            Success _ -> return (Failure e)
+        Success k -> do
+          mv <- v
+          case mv of
+            Failure e -> return (Failure e)
+            Success x -> return (Success (k x))
+  {-# INLINEABLE (<*>) #-}
+  m *> k = m >>= \_ -> k
+  {-# INLINE (*>) #-}
+
+instance (Semigroup e, Monad m) => Monad (ValidationT e m) where
+  m >>= k =
+    ValidationT $ do
+      a <- runValidationT m
+      case a of
+        Failure e -> return (Failure e)
+        Success x -> runValidationT (k x)
+  {-# INLINE (>>=) #-}

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-9.11
+resolver: lts-13.1
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -63,4 +63,4 @@ packages:
 # extra-lib-dirs: [/path/to/dir]
 #
 # Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor
+# compiler-check: newer-minor

tests/Main.hs

@@ -4,22 +4,43 @@ module Main where
 
 import Control.Applicative
 import Data.Either.Validation
+import Data.Either.ValidationT
 import Data.Monoid (Sum(..))
 
 import Test.QuickCheck (Property, Gen, (===), (.&&.), Arbitrary (..), forAllShrink, oneof)
 import Test.Framework (defaultMain)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit (assertEqual)
 
 
 main :: IO ()
 main = defaultMain
     [ testProperty "identity" $ identity (<|>) empty genValSumInt shrinkValidation
     , testProperty "associativity" $ associativity (<|>) genValSumInt shrinkValidation
+    , testCase "combine two ValidateT" $ do
+        v1 <- runValidationT $
+                ((,) <$> ValidationT (pure (Failure ["first"]))
+                     <*> ValidationT (pure (Failure ["second"])))
+          :: IO (Validation [String] ((), ()))
+        assertEqual "errors get accumulated"
+          v1
+          (Failure ["first", "second"])
     ]
 
+genValTSumInt :: Applicative m => Gen (ValidationT (Sum Int) m (Sum Int))
+genValTSumInt = genValidationT
+
 genValSumInt :: Gen (Validation (Sum Int) (Sum Int))
 genValSumInt = genValidation
 
+genValidationT ::
+     (Applicative m, Arbitrary a, Arbitrary b) => Gen (ValidationT a m b)
+genValidationT = oneof
+  [ fmap ValidationT (fmap pure (fmap Failure arbitrary))
+  , fmap ValidationT (fmap pure (fmap Success arbitrary))
+  ]
+
 genValidation :: (Arbitrary a, Arbitrary b) => Gen (Validation a b)
 genValidation = oneof
     [ fmap Failure arbitrary