either 3.4.2 → 5.0.3
raw patch · 10 files changed
Files
- .gitignore +19/−0
- .travis.yml +0/−8
- CHANGELOG.markdown +106/−0
- LICENSE +1/−1
- README.markdown +1/−3
- either.cabal +42/−16
- src/Control/Monad/Trans/Either.hs +0/−267
- src/Data/Either/Combinators.hs +61/−17
- src/Data/Either/Validation.hs +184/−0
- tests/Main.hs +49/−0
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -11,3 +12,21 @@ *.hi *~ *#+.cabal-sandbox/+cabal.sandbox.config+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*
− .travis.yml
@@ -1,8 +0,0 @@-language: haskell-notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313either\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
CHANGELOG.markdown view
@@ -1,3 +1,109 @@+5.0.3 [2025.06.17]+------------------+* Replace `test-framework` with `tasty` in the test suite.+* Drop support for pre-8.0 versions of GHC.++5.0.2 [2022.05.07]+------------------+* Tweak error messages of `fromRight'` and `fromLeft'` for clarity.+* Allow building with `mtl-2.3.*`.++5.0.1.1 [2019.05.02]+--------------------+* Only incur a `semigroups` dependency on pre-8.0 GHCs.++5.0.1 [2018.07.03]+------------------+* Make the `Semigroup`, `Apply`, and `Applicative` instances for `Validation`+ lazier.+* Make `vap` lazier in its second argument.+* Introduce `vapm`, an even lazier version of `vap` which requires a+ `Monoid` constraint. Also add `apm`, a counterpart for `Validation`.+* Use `test-framework` and `QuickCheck` in the test suite.++5+-+* Changed the semantics of the `Validation` `Alt` and `Alternative` instances to collect errors.+ The previous implementation did not correctly abide the laws.+* Added `vap`, for when users want validation like semantics but don't want to convert back and forth to validation all the time. Similarly, added `ealt` to give either's `Alt` semantics to validation.+* Dropped the deprecated `Control.Monad.Trans.Either`. Use `Control.Monad.Trans.Except` from `transformers` and/or+ `transformers-compat` instead.++4.5+----+* Add `MMonad` instance for `EitherT`+* Deprecate `Control.Monad.Trans.Either` in favor of `Control.Monad.Trans.Except`+* Add `firstEitherT`++4.4.1.1+-------+* Fixed building on newer GHCs. (type synonyms require explicit foralls for unused variables these days)++4.4.1+-----+* `transformers` 0.5 support+* Documentation fixes++4.4+---+* Support `mmorph`++4.3.4.1+-------+* Support `MonadRandom` 0.4++4.3.4+-----+* Support `bifunctors` 5, `profunctors` 5, and `semigroupoids` 5.++4.3.3.3+-------+* Fixed and enhanced documentation for `eitherToError`.++4.3.3.2+-------+* Support `exceptions` 0.8++4.3.3.1+-------+* Support `exceptions` 0.7++4.3.3+-----+* Added `eitherToError`.++4.3.2.1+-------+* Support `monad-control` 1.0++4.3.2+-----+* Added `Validation`.++4.3.0.2+-------+* Updated MonadRandom support.++4.3.0.1+-------+* Fixed import of `MonadCatch` to support versions of `base` before 4.6++4.3+---+* Inverted dependency between `free` and `either`.++4.2+---+* Added instances for `MonadThrow`, `MonadCatch`.++4.1+---+* Added instances for `MonadBase`, `MonadBaseControl`, and `MonadTransControl`.++4.0+---+* Updated dependencies.+ 3.4.2 ----- * Added 'Data.Either.Combinators'.
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2008-2011 Edward Kmett+Copyright 2008-2014 Edward Kmett All rights reserved.
README.markdown view
@@ -1,9 +1,7 @@ either ====== -[](http://travis-ci.org/ekmett/either)--This provides an `Either` monad transformer that unlike `ErrorT` is unencumbered by a constraint on its `Left` hand argument. This is needed for a number of applications of this monad transformer, notably in [recursion-schemes](https://github.com/ekmett/recursion-schemes).+[](https://hackage.haskell.org/package/either) [](https://github.com/ekmett/either/actions?query=workflow%3AHaskell-CI) Contact Information -------------------
either.cabal view
@@ -1,41 +1,67 @@ name: either category: Control, Monads-version: 3.4.2+version: 5.0.3 license: BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> stability: provisional homepage: http://github.com/ekmett/either/ bug-reports: http://github.com/ekmett/either/issues-copyright: Copyright (C) 2008-2013 Edward A. Kmett-synopsis: An either monad transformer-description: An either monad transformer+copyright: Copyright (C) 2008-2017 Edward A. Kmett+synopsis: Combinators for working with sums+description: Combinators for working with sums. build-type: Simple+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1 extra-source-files: .gitignore .ghci .vim.custom- .travis.yml CHANGELOG.markdown README.markdown source-repository head type: git- location: git://github.com/ekmett/either.git+ location: https://github.com/ekmett/either.git library build-depends:- base >= 4 && < 5,- MonadRandom == 0.1.*,- mtl >= 2.0 && < 2.2,- semigroups >= 0.8.3.1 && < 1,- semigroupoids >= 3 && < 4,- transformers >= 0.2 && < 0.4+ base >= 4.9 && < 5,+ bifunctors >= 4 && < 6,+ mtl >= 2.0 && < 2.4,+ profunctors >= 4 && < 6,+ semigroupoids >= 4 && < 7 - extensions: CPP- exposed-modules: Control.Monad.Trans.Either,- Data.Either.Combinators+ other-extensions: CPP Rank2Types ghc-options: -Wall hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Data.Either.Combinators+ Data.Either.Validation++test-suite tests+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: tests+ build-depends:+ base,+ either,+ tasty >= 1.4 && < 1.6,+ tasty-quickcheck >= 0.10 && < 0.12,+ QuickCheck >= 2.9 && < 2.17+ default-language: Haskell2010
− src/Control/Monad/Trans/Either.hs
@@ -1,267 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module : Control.Monad.Trans.Either--- Copyright : (C) 2008-2013 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : MPTCs------ This module provides a minimalist 'Either' monad transformer.--------------------------------------------------------------------------------module Control.Monad.Trans.Either- ( EitherT(..)- , eitherT- , bimapEitherT- , mapEitherT- , hoistEither- , left- , right- ) where--import Control.Applicative-import Control.Monad (liftM, MonadPlus(..))-import Control.Monad.Cont.Class-import Control.Monad.Error.Class-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Reader.Class-import Control.Monad.State (MonadState,get,put)-import Control.Monad.Trans.Class-import Control.Monad.Writer.Class-import Control.Monad.Random (MonadRandom,getRandom,getRandoms,getRandomR,getRandomRs)-import Data.Foldable-import Data.Function (on)-import Data.Functor.Bind-import Data.Functor.Plus-import Data.Traversable-import Data.Semigroup---- | 'EitherT' is a version of 'Control.Monad.Trans.Error.ErrorT' that does not--- require a spurious 'Control.Monad.Error.Class.Error' instance for the 'Left'--- case.------ 'Either' is a perfectly usable 'Monad' without such a constraint. 'ErrorT' is--- not the generalization of the current 'Either' monad, it is something else.------ This is necessary for both theoretical and practical reasons. For instance an--- apomorphism is the generalized anamorphism for this Monad, but it cannot be--- written with 'ErrorT'.------ In addition to the combinators here, the @errors@ package provides a large --- number of combinators for working with this type.-newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) }--instance Show (m (Either e a)) => Show (EitherT e m a) where- showsPrec d (EitherT m) = showParen (d > 10) $- showString "EitherT " . showsPrec 11 m- {-# INLINE showsPrec #-}--instance Read (m (Either e a)) => Read (EitherT e m a) where- readsPrec d = readParen (d > 10)- (\r' -> [ (EitherT m, t)- | ("EitherT", s) <- lex r'- , (m, t) <- readsPrec 11 s])- {-# INLINE readsPrec #-}--instance Eq (m (Either e a)) => Eq (EitherT e m a) where- (==) = (==) `on` runEitherT- {-# INLINE (==) #-}--instance Ord (m (Either e a)) => Ord (EitherT e m a) where- compare = compare `on` runEitherT- {-# INLINE compare #-}---- | Given a pair of actions, one to perform in case of failure, and one to perform--- in case of success, run an 'EitherT' and get back a monadic result.-eitherT :: Monad m => (a -> m c) -> (b -> m c) -> EitherT a m b -> m c-eitherT f g (EitherT m) = m >>= \z -> case z of- Left a -> f a- Right b -> g b-{-# INLINE eitherT #-}---- | Analogous to 'Left'. Equivalent to 'throwError'.-left :: Monad m => e -> EitherT e m a-left = EitherT . return . Left-{-# INLINE left #-}---- | Analogous to 'Right'. Equivalent to 'return'.-right :: Monad m => a -> EitherT e m a-right = return-{-# INLINE right #-}---- | Map over both failure and success.-bimapEitherT :: Functor m => (e -> f) -> (a -> b) -> EitherT e m a -> EitherT f m b-bimapEitherT f g (EitherT m) = EitherT (fmap h m) where- h (Left e) = Left (f e)- h (Right a) = Right (g a)-{-# INLINE bimapEitherT #-}---- | Map the unwrapped computation using the given function.------ @--- 'runEitherT' ('mapEitherT' f m) = f ('runEitherT' m)--- @-mapEitherT :: (m (Either e a) -> n (Either e' b)) -> EitherT e m a -> EitherT e' n b-mapEitherT f m = EitherT $ f (runEitherT m)-{-# INLINE mapEitherT #-}---- | Lift an 'Either' into an 'EitherT'-hoistEither :: Monad m => Either e a -> EitherT e m a-hoistEither = EitherT . return-{-# INLINE hoistEither #-}--instance Monad m => Functor (EitherT e m) where- fmap f = EitherT . liftM (fmap f) . runEitherT- {-# INLINE fmap #-}--instance Monad m => Apply (EitherT e m) where- EitherT f <.> EitherT v = EitherT $ f >>= \mf -> case mf of- Left e -> return (Left e)- Right k -> v >>= \mv -> case mv of- Left e -> return (Left e)- Right x -> return (Right (k x))- {-# INLINE (<.>) #-}--instance Monad m => Applicative (EitherT e m) where- pure a = EitherT $ return (Right a)- {-# INLINE pure #-}- EitherT f <*> EitherT v = EitherT $ f >>= \mf -> case mf of- Left e -> return (Left e)- Right k -> v >>= \mv -> case mv of- Left e -> return (Left e)- Right x -> return (Right (k x))- {-# INLINE (<*>) #-}--instance (Monad m, Monoid e) => Alternative (EitherT e m) where- EitherT m <|> EitherT n = EitherT $ m >>= \a -> case a of- Left l -> liftM (\b -> case b of- Left l' -> Left (mappend l l')- Right r -> Right r) n- Right r -> return (Right r)- {-# INLINE (<|>) #-}-- empty = EitherT $ return (Left mempty)- {-# INLINE empty #-}--instance (Monad m, Monoid e) => MonadPlus (EitherT e m) where- mplus = (<|>)- {-# INLINE mplus #-}-- mzero = empty- {-# INLINE mzero #-}--instance Monad m => Semigroup (EitherT e m a) where- EitherT m <> EitherT n = EitherT $ m >>= \a -> case a of- Left _ -> n- Right r -> return (Right r)- {-# INLINE (<>) #-}--instance (Monad m, Semigroup e) => Alt (EitherT e m) where- EitherT m <!> EitherT n = EitherT $ m >>= \a -> case a of- Left l -> liftM (\b -> case b of- Left l' -> Left (l <> l')- Right r -> Right r) n- Right r -> return (Right r)- {-# INLINE (<!>) #-}--instance Monad m => Bind (EitherT e m) where- (>>-) = (>>=)- {-# INLINE (>>-) #-}--instance Monad m => Monad (EitherT e m) where- return a = EitherT $ return (Right a)- {-# INLINE return #-}- m >>= k = EitherT $ do- a <- runEitherT m- case a of- Left l -> return (Left l)- Right r -> runEitherT (k r)- {-# INLINE (>>=) #-}- fail = EitherT . fail- {-# INLINE fail #-}---instance Monad m => MonadError e (EitherT e m) where- throwError = EitherT . return . Left- {-# INLINE throwError #-}- EitherT m `catchError` h = EitherT $ m >>= \a -> case a of- Left l -> runEitherT (h l)- Right r -> return (Right r)- {-# INLINE catchError #-}--instance MonadFix m => MonadFix (EitherT e m) where- mfix f = EitherT $ mfix $ \a -> runEitherT $ f $ case a of- Right r -> r- _ -> error "empty mfix argument"- {-# INLINE mfix #-}--instance MonadTrans (EitherT e) where- lift = EitherT . liftM Right- {-# INLINE lift #-}--instance MonadIO m => MonadIO (EitherT e m) where- liftIO = lift . liftIO- {-# INLINE liftIO #-}--instance MonadCont m => MonadCont (EitherT e m) where- callCC f = EitherT $- callCC $ \c ->- runEitherT (f (\a -> EitherT $ c (Right a)))- {-# INLINE callCC #-}--instance MonadReader r m => MonadReader r (EitherT e m) where- ask = lift ask- {-# INLINE ask #-}- local f (EitherT m) = EitherT (local f m)- {-# INLINE local #-}--instance MonadState s m => MonadState s (EitherT e m) where- get = lift get- {-# INLINE get #-}- put = lift . put- {-# INLINE put #-}--instance MonadWriter s m => MonadWriter s (EitherT e m) where- tell = lift . tell- {-# INLINE tell #-}- listen = mapEitherT $ \ m -> do- (a, w) <- listen m- return $! fmap (\ r -> (r, w)) a- {-# INLINE listen #-}- pass = mapEitherT $ \ m -> pass $ do- a <- m- return $! case a of- Left l -> (Left l, id)- Right (r, f) -> (Right r, f)- {-# INLINE pass #-}--instance MonadRandom m => MonadRandom (EitherT e m) where- getRandom = lift getRandom- {-# INLINE getRandom #-}- getRandoms = lift getRandoms- {-# INLINE getRandoms #-}- getRandomR = lift . getRandomR- {-# INLINE getRandomR #-}- getRandomRs = lift . getRandomRs- {-# INLINE getRandomRs #-}--instance Foldable m => Foldable (EitherT e m) where- foldMap f = foldMap (either mempty f) . runEitherT- {-# INLINE foldMap #-}--instance (Monad f, Traversable f) => Traversable (EitherT e f) where- traverse f (EitherT a) =- EitherT <$> traverse (either (pure . Left) (fmap Right . f)) a- {-# INLINE traverse #-}
src/Data/Either/Combinators.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Either.Combinators--- Copyright : (c) Gregory Crosswhite, Chris Done, Edward Kmett+-- Copyright : (c) 2010-2014 Gregory Crosswhite, Chris Done, Edward Kmett -- License : BSD-style -- -- Maintainer : ekmett@gmail.com@@ -32,14 +32,18 @@ , unlessRight , leftToMaybe , rightToMaybe+ , maybeToLeft+ , maybeToRight+ , eitherToError+ , swapEither ) where -import Control.Applicative+import Control.Monad.Error.Class ( MonadError(throwError) ) -- --------------------------------------------------------------------------- -- Functions over Either --- |The 'isLeft' function returns 'True' iff its argument is of the form @Left _@.+-- |The 'isLeft' function returns 'True' iff its argument is of the form @'Left' _@. -- -- Using @Control.Lens@: --@@ -56,7 +60,7 @@ isLeft (Left _) = True isLeft _ = False --- |The 'isRight' function returns 'True' iff its argument is of the form @Right _@.+-- |The 'isRight' function returns 'True' iff its argument is of the form @'Right' _@. -- -- Using @Control.Lens@: --@@ -85,11 +89,11 @@ -- >>> fromLeft' (Left 12) -- 12 fromLeft' :: Either a b -> a-fromLeft' (Right _) = error "Data.Either.Combinators.fromLeft: Argument takes form 'Right _'" -- yuck+fromLeft' (Right _) = error "Data.Either.Combinators.fromLeft' encountered a value of form 'Right _', consider using Data.Either.Combinators.fromLeft with a default value." -- yuck fromLeft' (Left x) = x -- | Extracts the element out of a 'Right' and--- throws an error if its argument take the form @'Left' _@.+-- throws an error if its argument take the form @'Left' _@. -- -- Using @Control.Lens@: --@@ -100,7 +104,7 @@ -- >>> fromRight' (Right 12) -- 12 fromRight' :: Either a b -> b-fromRight' (Left _) = error "Data.Either.Combinators.fromRight: Argument takes form 'Left _'" -- yuck+fromRight' (Left _) = error "Data.Either.Combinators.fromRight' encountered a value of form 'Left _', consider using Data.Either.Combinators.fromRight with a default value." -- yuck fromRight' (Right x) = x -- | The 'mapBoth' function takes two functions and applies the first if iff the value@@ -128,7 +132,7 @@ mapBoth _ f (Right x) = Right (f x) -- | The 'mapLeft' function takes a function and applies it to an Either value--- iff the value takes the form 'Left _'.+-- iff the value takes the form @'Left' _@. -- -- Using @Data.Bifunctor@: --@@ -156,13 +160,13 @@ mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f = mapBoth f id --- | The 'mapLeft' function takes a function and applies it to an Either value--- iff the value takes the form 'Left _'.+-- | The 'mapRight' function takes a function and applies it to an Either value+-- iff the value takes the form @'Right' _@. -- -- Using @Data.Bifunctor@: -- -- @--- 'mapRight' = first+-- 'mapRight' = second -- @ -- -- Using @Control.Arrow@:@@ -174,7 +178,7 @@ -- Using @Control.Lens@: -- -- @--- 'mapRight' = 'over' '_Right'+-- 'mapRight' = over _Right -- @ -- -- >>> mapRight (*2) (Left "hello")@@ -186,7 +190,7 @@ mapRight = mapBoth id -- | The 'whenLeft' function takes an 'Either' value and a function which returns a monad.--- The monad is only executed when the given argument takes the form @Left _@, otherwise+-- The monad is only executed when the given argument takes the form @'Left' _@, otherwise -- it does nothing. -- -- Using @Control.Lens@:@@ -201,8 +205,8 @@ whenLeft (Left x) f = f x whenLeft _ _ = pure () --- | The 'whenLeft' function takes an 'Either' value and a function which returns a monad.--- The monad is only executed when the given argument takes the form @Right _@, otherwise+-- | The 'whenRight' function takes an 'Either' value and a function which returns a monad.+-- The monad is only executed when the given argument takes the form @'Right' _@, otherwise -- it does nothing. -- -- Using @Data.Foldable@:@@ -234,7 +238,7 @@ -- | Extract the left value or a default. -- -- @--- 'fromLeft' ≡ 'either' 'id'+-- 'fromLeft' b ≡ 'either' 'id' ('const' b) -- @ -- -- >>> fromLeft "hello" (Right 42)@@ -249,7 +253,7 @@ -- | Extract the right value or a default. -- -- @--- 'fromRight' b ≡ 'either' b 'id'+-- 'fromRight' b ≡ 'either' ('const' b) 'id' -- @ -- -- >>> fromRight "hello" (Right "world")@@ -302,3 +306,43 @@ -- Just 12 rightToMaybe :: Either a b -> Maybe b rightToMaybe = either (const Nothing) Just++-- | Maybe produce a 'Left', otherwise produce a 'Right'.+--+-- >>> maybeToLeft "default" (Just 12)+-- Left 12+--+-- >>> maybeToLeft "default" Nothing+-- Right "default"+maybeToLeft :: b -> Maybe a -> Either a b+maybeToLeft _ (Just x) = Left x+maybeToLeft y Nothing = Right y++-- | Maybe produce a 'Right', otherwise produce a 'Left'.+--+-- >>> maybeToRight "default" (Just 12)+-- Right 12+--+-- >>> maybeToRight "default" Nothing+-- Left "default"+maybeToRight :: b -> Maybe a -> Either b a+maybeToRight _ (Just x) = Right x+maybeToRight y Nothing = Left y++-- | Generalize @Either e@ as @MonadError e m@.+--+-- If the argument has form @Left e@, an error is produced in the monad via+-- 'throwError'. Otherwise, the @Right a@ part is forwarded.+eitherToError :: (MonadError e m) => Either e a -> m a+eitherToError = either throwError return++-- | Swap the 'Left' and 'Right' sides of an 'Either'.+--+-- >>> swapEither (Right 3)+-- Left 3+--+-- >>> swapEither (Left "error")+-- Right "error"+swapEither :: Either e a -> Either a e+swapEither = either Right Left+{-# INLINE swapEither #-}
+ src/Data/Either/Validation.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE CPP #-}+{-# 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.Profunctor+import Prelude hiding (foldr)++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif++-- | '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+#if !(MIN_VERSION_base(4,11,0))+ x@Success{} `mappend` _ = x+ _ `mappend` x@Success{} = x+ Failure e1 `mappend` Failure e2 = Failure (e1 `mappend` e2)+#endif++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 #-}
+ tests/Main.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative+import Data.Either.Validation+import Data.Monoid (Sum(..))++import Test.QuickCheck (Property, Gen, (===), (.&&.), Arbitrary (..), forAllShrink, oneof)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty)+++main :: IO ()+main = defaultMain $+ testGroup "either"+ [ testProperty "identity" $ identity (<|>) empty genValSumInt shrinkValidation+ , testProperty "associativity" $ associativity (<|>) genValSumInt shrinkValidation+ ]++genValSumInt :: Gen (Validation (Sum Int) (Sum Int))+genValSumInt = genValidation++genValidation :: (Arbitrary a, Arbitrary b) => Gen (Validation a b)+genValidation = oneof+ [ fmap Failure arbitrary+ , fmap Success arbitrary+ ]++shrinkValidation :: (Arbitrary a, Arbitrary b) => Validation a b -> [Validation a b]+shrinkValidation (Success x) = Success `fmap` shrink x+shrinkValidation (Failure x) = Failure `fmap` shrink x++-- -- empty is a neutral element+-- empty <|> u = u+-- u <|> empty = u+-- -- (<|>) is associative+-- u <|> (v <|> w) = (u <|> v) <|> w++identity :: (Eq a, Show a) => (a -> a -> a) -> a -> Gen a -> (a -> [a]) -> Property+identity f i gen shr = forAllShrink gen shr $ \x ->+ f x i === x .&&. f i x === x++associativity :: (Eq a, Show a) => (a -> a -> a) -> Gen a -> (a -> [a]) -> Property+associativity f gen shr =+ forAllShrink gen shr $ \x ->+ forAllShrink gen shr $ \y ->+ forAllShrink gen shr $ \z ->+ f x (f y z) === f (f x y) z