New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add ValidationT #58

Closed
wants to merge 1 commit into
base: master
from
Closed
Changes from all commits
Commits
File filter...
Filter file types
Jump to…
Jump to file or symbol
Failed to load files and symbols.
+90 −2
Diff settings

Always

Just for now

Copy path View file
@@ -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
Copy path View file
@@ -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 (>>=) #-}
Copy path View file
@@ -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
Copy path View file
@@ -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
ProTip! Use n and p to navigate between commits in a pull request.