either 4.3.4.1 → 5.0.3
raw patch · 9 files changed
Files
- .gitignore +19/−0
- .travis.yml +0/−8
- CHANGELOG.markdown +50/−0
- README.markdown +1/−3
- either.cabal +40/−21
- src/Control/Monad/Trans/Either.hs +0/−354
- src/Data/Either/Combinators.hs +27/−7
- src/Data/Either/Validation.hs +60/−17
- 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,53 @@+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
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,48 +1,67 @@ name: either category: Control, Monads-version: 4.3.4.1+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-2014 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,+ base >= 4.9 && < 5, bifunctors >= 4 && < 6,- exceptions >= 0.5 && < 0.9,- free >= 4.9 && < 5,- monad-control >= 0.3.2 && < 1.1,- MonadRandom >= 0.1 && < 0.5,- mtl >= 2.0 && < 2.3,+ mtl >= 2.0 && < 2.4, profunctors >= 4 && < 6,- semigroups >= 0.8.3.1 && < 1,- semigroupoids >= 4 && < 6,- transformers >= 0.2 && < 0.5,- transformers-base >= 0.4 && < 0.5+ semigroupoids >= 4 && < 7 - extensions: CPP- exposed-modules: Control.Monad.Trans.Either- Data.Either.Combinators- Data.Either.Validation+ 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,354 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module : Control.Monad.Trans.Either--- Copyright : (C) 2008-2014 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- , bracketEitherT- , bracketEitherT_- , left- , right- , swapEitherT- ) where--import Control.Applicative-import Control.Monad (liftM, MonadPlus(..))-import Control.Monad.Base (MonadBase(..), liftBaseDefault)-import Control.Monad.Cont.Class-import Control.Monad.Error.Class-import Control.Monad.Free.Class-import Control.Monad.Catch as MonadCatch-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.Trans.Control (MonadBaseControl(..), MonadTransControl(..), defaultLiftBaseWith, defaultRestoreM)-import Control.Monad.Writer.Class-import Control.Monad.Random (MonadRandom,getRandom,getRandoms,getRandomR,getRandomRs)-import Data.Either.Combinators ( swapEither )-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 #-}---- | Acquire a resource in 'EitherT' and then perform an action with it,--- cleaning up afterwards regardless of error. Like--- 'Control.Exception.bracket', but acting only in 'EitherT'.-bracketEitherT :: Monad m => EitherT e m a -> (a -> EitherT e m b) -> (a -> EitherT e m c) -> EitherT e m c-bracketEitherT before after thing = do- a <- before- r <- thing a `catchError` (\err -> after a >> left err)- -- If catchError already triggered, then `after` already ran *and* we are- -- in a Left state, so `after` will not run again here.- _ <- after a- return r---- | Version of 'bracketEitherT' which discards the result from the initial--- action.-bracketEitherT_ :: Monad m => EitherT e m a -> EitherT e m b -> EitherT e m c -> EitherT e m c-bracketEitherT_ before after thing = do- _ <- before- r <- thing `catchError` (\err -> after >> left err)- -- If catchError already triggered, then `after` already ran *and* we are- -- in a Left state, so `after` will not run again here.- _ <- after- return r---- | Monad transformer version of 'swapEither'.-swapEitherT :: (Functor m) => EitherT e m a -> EitherT a m e-swapEitherT = EitherT . fmap swapEither . runEitherT-{-# INLINE swapEitherT #-}--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 #-}---- | Throws exceptions into the base monad.-instance MonadThrow m => MonadThrow (EitherT e m) where- throwM = lift . throwM- {-# INLINE throwM #-}---- | Catches exceptions from the base monad.-instance MonadCatch m => MonadCatch (EitherT e m) where- catch (EitherT m) f = EitherT $ MonadCatch.catch m (runEitherT . f)- {-# INLINE catch #-}--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 (Functor f, MonadFree f m) => MonadFree f (EitherT e m) where- wrap = EitherT . wrap . fmap runEitherT--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 #-}--instance MonadBase b m => MonadBase b (EitherT e m) where- liftBase = liftBaseDefault- {-# INLINE liftBase #-}--#if MIN_VERSION_monad_control(1,0,0)--instance MonadTransControl (EitherT e) where- type StT (EitherT e) a = Either e a- liftWith f = EitherT $ liftM return $ f runEitherT- {-# INLINE liftWith #-}- restoreT = EitherT- {-# INLINE restoreT #-}--instance MonadBaseControl b m => MonadBaseControl b (EitherT e m) where- type StM (EitherT e m) a = StM m (StT (EitherT e) a)- liftBaseWith = defaultLiftBaseWith- {-# INLINE liftBaseWith #-}- restoreM = defaultRestoreM- {-# INLINE restoreM #-}--#else--instance MonadTransControl (EitherT e) where- newtype StT (EitherT e) a = StEitherT {unStEitherT :: Either e a}- liftWith f = EitherT $ liftM return $ f $ liftM StEitherT . runEitherT- {-# INLINE liftWith #-}- restoreT = EitherT . liftM unStEitherT- {-# INLINE restoreT #-}- -instance MonadBaseControl b m => MonadBaseControl b (EitherT e m) where- newtype StM (EitherT e m) a = StMEitherT { unStMEitherT :: StM m (StT (EitherT e) a) }- liftBaseWith = defaultLiftBaseWith StMEitherT- {-# INLINE liftBaseWith #-}- restoreM = defaultRestoreM unStMEitherT- {-# INLINE restoreM #-}--#endif
src/Data/Either/Combinators.hs view
@@ -32,11 +32,12 @@ , unlessRight , leftToMaybe , rightToMaybe+ , maybeToLeft+ , maybeToRight , eitherToError , swapEither ) where -import Control.Applicative import Control.Monad.Error.Class ( MonadError(throwError) ) -- ---------------------------------------------------------------------------@@ -88,7 +89,7 @@ -- >>> 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@@ -103,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@@ -237,7 +238,7 @@ -- | Extract the left value or a default. -- -- @--- 'fromLeft' ≡ 'either' 'id'+-- 'fromLeft' b ≡ 'either' 'id' ('const' b) -- @ -- -- >>> fromLeft "hello" (Right 42)@@ -252,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")@@ -306,7 +307,28 @@ 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@@ -316,13 +338,11 @@ -- | 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
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -----------------------------------------------------------------------------@@ -21,6 +22,10 @@ , eitherToValidation , validationToEither , _Validation+ , vap+ , ealt+ -- combinators that leak less, but require monoid constraints+ , vapm, apm ) where import Control.Applicative@@ -29,12 +34,14 @@ import Data.Bitraversable(Bitraversable(bitraverse)) import Data.Foldable (Foldable(foldr)) import Data.Functor.Alt (Alt((<!>)))-import Data.Monoid (Monoid(mappend, mempty))+import Data.Functor.Apply (Apply ((<.>))) import Data.Profunctor-import Data.Semigroup (Semigroup((<>)))-import Data.Traversable (Traversable(traverse)) 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@@ -45,16 +52,22 @@ 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- Failure e1 <*> Failure e2 = Failure (e1 <> e2)- Failure e1 <*> Success _ = Failure e1- Success _ <*> Failure e2 = Failure e2- Success f <*> Success a = Success (f a)+ (<*>) = (<.>) -instance Alt (Validation e) where- Failure _ <!> x = x- Success a <!> _ = Success a+-- | 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@@ -81,17 +94,17 @@ 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)- Failure _ <> Success a2 = Success a2- Success a1 <> Failure _ = Success a1- Success a1 <> Success _ = Success a1 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)- Failure _ `mappend` Success a2 = Success a2- Success a1 `mappend` Failure _ = Success a1- Success a1 `mappend` Success _ = Success a1+#endif type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) @@ -117,7 +130,7 @@ Success y -> Right y) {-# INLINE _Success #-} -type Iso s t a b = (Profunctor p, Functor f) => p a (f b) -> p s (f t)+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)@@ -139,3 +152,33 @@ _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