packages feed

either 3.2 → 5.0.3

raw patch · 10 files changed

Files

.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,127 @@+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++3.4+---+* Delegate `fail` to the underlying `Monad`, rather than `error`.++3.3+---+* Inverted roles between `Semigroup` and `Alt`. This let us write `Alternative` and `MonadPlus` instances that are compatible.+* Removed the `Functor` constraint on most instances in exchange for incurring a `Monad` constraint on `Traversable`. `EitherT`+  is after all, a `Monad` transformer first and foremost.+ 3.2 --- * Changed the `Semigroup` to use a `Semigroup` to combine `Left` branches. Left `Alt` untouched, so you can mix and match.
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 ====== -[![Build Status](https://secure.travis-ci.org/ekmett/either.png?branch=master)](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.+[![Hackage](https://img.shields.io/hackage/v/either.svg)](https://hackage.haskell.org/package/either) [![Build Status](https://github.com/ekmett/either/workflows/Haskell-CI/badge.svg)](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.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+  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,241 +0,0 @@-{-# 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)-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 Functor m => Functor (EitherT e m) where-  fmap f = EitherT . fmap (fmap f) . runEitherT-  {-# INLINE fmap #-}--instance (Functor m, 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 (Functor m, 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, Semigroup e) => Semigroup (EitherT e m a) 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 (Functor m, Monad m) => Alt (EitherT e m) where-  EitherT m <!> EitherT n = EitherT $ m >>= \a -> case a of-    Left _  -> n-    Right r -> return (Right r)-  {-# INLINE (<!>) #-}--instance (Functor m, 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 (>>=) #-}--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 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