either 3.4.1 → 5.0.3
raw patch · 10 files changed
Files
- .gitignore +19/−0
- .travis.yml +0/−8
- CHANGELOG.markdown +110/−0
- LICENSE +1/−1
- README.markdown +1/−3
- either.cabal +42/−15
- src/Control/Monad/Trans/Either.hs +0/−267
- src/Data/Either/Combinators.hs +348/−0
- 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,113 @@+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'.+ 3.4.1 ----- * Trustworthy despite UndecidableInstances
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,40 +1,67 @@ name: either category: Control, Monads-version: 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-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+ 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
@@ -0,0 +1,348 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Either.Combinators+-- Copyright : (c) 2010-2014 Gregory Crosswhite, Chris Done, Edward Kmett+-- License : BSD-style+--+-- Maintainer : ekmett@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Functions for probing and unwrapping values inside of 'Either'.+--+-- Most of these combinators are provided for pedagogical purposes and exist+-- in more general forms in other libraries. To that end alternative definitions+-- are supplied below.+--+-----------------------------------------------------------------------------++module Data.Either.Combinators+ ( isLeft+ , isRight+ , fromLeft+ , fromRight+ , fromLeft'+ , fromRight'+ , mapBoth+ , mapLeft+ , mapRight+ , whenLeft+ , whenRight+ , unlessLeft+ , unlessRight+ , leftToMaybe+ , rightToMaybe+ , maybeToLeft+ , maybeToRight+ , eitherToError+ , swapEither+ ) where++import Control.Monad.Error.Class ( MonadError(throwError) )++-- ---------------------------------------------------------------------------+-- Functions over Either++-- |The 'isLeft' function returns 'True' iff its argument is of the form @'Left' _@.+--+-- Using @Control.Lens@:+--+-- @+-- 'isLeft' ≡ has _Left+-- @+--+-- >>> isLeft (Left 12)+-- True+--+-- >>> isLeft (Right 12)+-- False+isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++-- |The 'isRight' function returns 'True' iff its argument is of the form @'Right' _@.+--+-- Using @Control.Lens@:+--+-- @+-- 'isRight' ≡ has _Right+-- @+--+-- >>> isRight (Left 12)+-- False+--+-- >>> isRight (Right 12)+-- True+isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False++-- | Extracts the element out of a 'Left' and+-- throws an error if its argument take the form @'Right' _@.+--+-- Using @Control.Lens@:+--+-- @+-- 'fromLeft'' x ≡ x^?!_Left+-- @+--+-- >>> fromLeft' (Left 12)+-- 12+fromLeft' :: Either a b -> a+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' _@.+--+-- Using @Control.Lens@:+--+-- @+-- 'fromRight'' x ≡ x^?!_Right+-- @+--+-- >>> fromRight' (Right 12)+-- 12+fromRight' :: Either a b -> b+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+-- takes the form @'Left' _@ and the second if the value takes the form @'Right' _@.+--+-- Using @Data.Bifunctor@:+--+-- @+-- 'mapBoth' = bimap+-- @+--+-- Using @Control.Arrow@:+--+-- @+-- 'mapBoth' = ('Control.Arrow.+++')+-- @+--+-- >>> mapBoth (*2) (*3) (Left 4)+-- Left 8+--+-- >>> mapBoth (*2) (*3) (Right 4)+-- Right 12+mapBoth :: (a -> c) -> (b -> d) -> Either a b -> Either c d+mapBoth f _ (Left x) = Left (f x)+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' _@.+--+-- Using @Data.Bifunctor@:+--+-- @+-- 'mapLeft' = first+-- @+--+-- Using @Control.Arrow@:+--+-- @+-- 'mapLeft' = ('Control.Arrow.left')+-- @+--+-- Using @Control.Lens@:+--+-- @+-- 'mapLeft' = over _Left+-- @+--+-- >>> mapLeft (*2) (Left 4)+-- Left 8+--+-- >>> mapLeft (*2) (Right "hello")+-- Right "hello"+mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f = mapBoth f id++-- | The 'mapRight' function takes a function and applies it to an Either value+-- iff the value takes the form @'Right' _@.+--+-- Using @Data.Bifunctor@:+--+-- @+-- 'mapRight' = second+-- @+--+-- Using @Control.Arrow@:+--+-- @+-- 'mapRight' = ('Control.Arrow.right')+-- @+--+-- Using @Control.Lens@:+--+-- @+-- 'mapRight' = over _Right+-- @+--+-- >>> mapRight (*2) (Left "hello")+-- Left "hello"+--+-- >>> mapRight (*2) (Right 4)+-- Right 8+mapRight :: (b -> c) -> Either a b -> Either a c+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+-- it does nothing.+--+-- Using @Control.Lens@:+--+-- @+-- 'whenLeft' ≡ forOf_ _Left+-- @+--+-- >>> whenLeft (Left 12) print+-- 12+whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m ()+whenLeft (Left x) f = f x+whenLeft _ _ = pure ()++-- | 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@:+--+-- @+-- 'whenRight' ≡ 'forM_'+-- @+--+-- Using @Control.Lens@:+--+-- @+-- 'whenRight' ≡ forOf_ _Right+-- @+--+-- >>> whenRight (Right 12) print+-- 12+whenRight :: Applicative m => Either a b -> (b -> m ()) -> m ()+whenRight (Right x) f = f x+whenRight _ _ = pure ()++-- | A synonym of 'whenRight'.+unlessLeft :: Applicative m => Either a b -> (b -> m ()) -> m ()+unlessLeft = whenRight++-- | A synonym of 'whenLeft'.+unlessRight :: Applicative m => Either a b -> (a -> m ()) -> m ()+unlessRight = whenLeft++-- | Extract the left value or a default.+--+-- @+-- 'fromLeft' b ≡ 'either' 'id' ('const' b)+-- @+--+-- >>> fromLeft "hello" (Right 42)+-- "hello"+--+-- >>> fromLeft "hello" (Left "world")+-- "world"+fromLeft :: a -> Either a b -> a+fromLeft _ (Left x) = x+fromLeft x _ = x++-- | Extract the right value or a default.+--+-- @+-- 'fromRight' b ≡ 'either' ('const' b) 'id'+-- @+--+-- >>> fromRight "hello" (Right "world")+-- "world"+--+-- >>> fromRight "hello" (Left 42)+-- "hello"+fromRight :: b -> Either a b -> b+fromRight _ (Right x) = x+fromRight x _ = x++-- | Maybe get the 'Left' side of an 'Either'.+--+-- @+-- 'leftToMaybe' ≡ 'either' 'Just' ('const' 'Nothing')+-- @+--+-- Using @Control.Lens@:+--+-- @+-- 'leftToMaybe' ≡ preview _Left+-- 'leftToMaybe' x ≡ x^?_Left+-- @+--+-- >>> leftToMaybe (Left 12)+-- Just 12+--+-- >>> leftToMaybe (Right 12)+-- Nothing+leftToMaybe :: Either a b -> Maybe a+leftToMaybe = either Just (const Nothing)++-- | Maybe get the 'Right' side of an 'Either'.+--+-- @+-- 'rightToMaybe' ≡ 'either' ('const' 'Nothing') 'Just'+-- @+--+-- Using @Control.Lens@:+--+-- @+-- 'rightToMaybe' ≡ preview _Right+-- 'rightToMaybe' x ≡ x^?_Right+-- @+--+-- >>> rightToMaybe (Left 12)+-- Nothing+--+-- >>> rightToMaybe (Right 12)+-- 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