either-4.4.1/0000755000000000000000000000000012532071527011172 5ustar0000000000000000either-4.4.1/.ghci0000644000000000000000000000012512532071527012103 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h either-4.4.1/.gitignore0000644000000000000000000000010412532071527013155 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# either-4.4.1/.travis.yml0000644000000000000000000000033312532071527013302 0ustar0000000000000000language: haskell notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313either\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" either-4.4.1/.vim.custom0000644000000000000000000000137712532071527013307 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" either-4.4.1/CHANGELOG.markdown0000644000000000000000000000317712532071527014235 0ustar00000000000000004.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. 3.1 --- * Added instances for `mtl` classes and `MonadRandom`. * The meaning of `mapEitherT` has changed to match `mapErrorT` in the `mtl`. The old `mapEitherT` is now `bimapEitherT`. 3.0.3 ----- * Started `CHANGELOG` either-4.4.1/either.cabal0000644000000000000000000000267412532071527013447 0ustar0000000000000000name: either category: Control, Monads version: 4.4.1 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett 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 build-type: Simple 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 library build-depends: base >= 4 && < 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, mmorph >= 1.0.0 && < 1.1, profunctors >= 4 && < 6, semigroups >= 0.8.3.1 && < 1, semigroupoids >= 4 && < 6, transformers >= 0.2 && < 0.5, transformers-base >= 0.4 && < 0.5 extensions: CPP exposed-modules: Control.Monad.Trans.Either Data.Either.Combinators Data.Either.Validation ghc-options: -Wall hs-source-dirs: src either-4.4.1/LICENSE0000644000000000000000000000266012532071527012203 0ustar0000000000000000Copyright 2008-2014 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. either-4.4.1/README.markdown0000644000000000000000000000113512532071527013673 0ustar0000000000000000either ====== [![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](https://github.com/ekmett/recursion-schemes). Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett either-4.4.1/Setup.lhs0000644000000000000000000000016512532071527013004 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain either-4.4.1/src/0000755000000000000000000000000012532071527011761 5ustar0000000000000000either-4.4.1/src/Control/0000755000000000000000000000000012532071527013401 5ustar0000000000000000either-4.4.1/src/Control/Monad/0000755000000000000000000000000012532071527014437 5ustar0000000000000000either-4.4.1/src/Control/Monad/Trans/0000755000000000000000000000000012532071527015526 5ustar0000000000000000either-4.4.1/src/Control/Monad/Trans/Either.hs0000644000000000000000000002706412532071527017313 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Either -- Copyright : (C) 2008-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 Control.Monad.Morph (MFunctor, hoist) 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 #-} instance MFunctor (EitherT e) where hoist f = EitherT . f . runEitherT {-# INLINE hoist #-} -- | 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 either-4.4.1/src/Data/0000755000000000000000000000000012532071527012632 5ustar0000000000000000either-4.4.1/src/Data/Either/0000755000000000000000000000000012532071527014052 5ustar0000000000000000either-4.4.1/src/Data/Either/Combinators.hs0000644000000000000000000001573212532071527016676 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 , 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' _@. -- -- 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: Argument takes form 'Right _'" -- 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: Argument takes form 'Left _'" -- 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' ≡ 'either' 'id' -- @ -- -- >>> 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' 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 -- | 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 #-} either-4.4.1/src/Data/Either/Validation.hs0000644000000000000000000001023412532071527016500 0ustar0000000000000000{-# 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 ) 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.Monoid (Monoid(mappend, mempty)) import Data.Profunctor import Data.Semigroup (Semigroup((<>))) import Data.Traversable (Traversable(traverse)) import Prelude hiding (foldr) -- | '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 => 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 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 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 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 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 = (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 #-}