either 4.5 → 5

raw patch · 6 files changed

+130/−400 lines, 6 filesdep +eitherdep +hedgehogdep −MonadRandomdep −exceptionsdep −freedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: either, hedgehog

Dependencies removed: MonadRandom, exceptions, free, mmorph, monad-control, transformers, transformers-base

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +8/−0
• either.cabal +19/−17
• src/Control/Monad/Trans/Either.hs +0/−376
• src/Data/Either/Combinators.hs +23/−0
• src/Data/Either/Validation.hs +26/−7
• tests/Main.hs +54/−0

@@ -1,3 +1,11 @@+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`

@@ -1,17 +1,17 @@ name:          either category:      Control, Monads-version:       4.5+version:       5 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 extra-source-files:   .gitignore@@ -29,21 +29,23 @@   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.6,     mtl               >= 2.0     && < 2.3,-    mmorph            >= 1.0.0   && < 1.2,     profunctors       >= 4       && < 6,     semigroups        >= 0.8.3.1 && < 1,-    semigroupoids     >= 4       && < 6,-    transformers      >= 0.2     && < 0.6,-    transformers-base >= 0.4     && < 0.5+    semigroupoids     >= 4       && < 6 -  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, hedgehog+  default-language: Haskell2010

@@ -1,376 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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 <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  MPTCs------ This module provides a minimalist 'Either' monad transformer.--------------------------------------------------------------------------------module Control.Monad.Trans.Either-{-# DEPRECATED "Use \"Control.Monad.Trans.Except\" from transformers or transformers-compat instead." #-}-  ( EitherT(..)-  , eitherT-  , bimapEitherT-  , mapEitherT-  , hoistEither-  , bracketEitherT-  , bracketEitherT_-  , left-  , right-  , swapEitherT-  , firstEitherT-  ) 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(..), MMonad(..))-import Data.Either.Combinators ( swapEither )-#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-#endif-import Data.Function (on)-import Data.Functor.Bind-import Data.Functor.Plus-#if __GLASGOW_HASKELL__ < 710-import Data.Traversable-#endif-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 #-}--instance MMonad (EitherT e) where-  embed f m = EitherT $ do-    x <- runEitherT . f . runEitherT $ m-    return $ case x of-        Left         e  -> Left e-        Right (Left  e) -> Left e-        Right (Right a) -> Right a-  {-# INLINE embed #-}---- | 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 over failure-firstEitherT :: Functor m => (e -> f) -> EitherT e m a -> EitherT f m a-firstEitherT f = bimapEitherT f id-{-# INLINE firstEitherT #-}---- | 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

@@ -33,6 +33,8 @@   , unlessRight   , leftToMaybe   , rightToMaybe+  , maybeToLeft+  , maybeToRight   , eitherToError   , swapEither   ) where@@ -309,6 +311,27 @@ rightToMaybe :: Either a b -> Maybe b rightToMaybe = either (const Nothing) Just +-- | Maybe produce a 'Left', otherwise produce a 'Right'.+--+-- >>> maybeToRight "default" (Just 12)+-- Left 12+--+-- >>> maybeToRight "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@. --

@@ -21,6 +21,8 @@   , eitherToValidation   , validationToEither   , _Validation+  , vap+  , ealt   ) where  import Control.Applicative@@ -29,6 +31,7 @@ import Data.Bitraversable(Bitraversable(bitraverse)) import Data.Foldable (Foldable(foldr)) import Data.Functor.Alt (Alt((<!>)))+import Data.Functor.Apply (Apply ((<.>))) import Data.Monoid (Monoid(mappend, mempty)) import Data.Profunctor import Data.Semigroup (Semigroup((<>)))@@ -45,16 +48,20 @@    fmap _ (Failure e) = Failure e    fmap f (Success a) = Success (f a) +instance Semigroup e => Apply (Validation e) where+  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 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 => 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@@ -139,3 +146,15 @@ _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) (Left n) = Left (m <> n)+vap (Left m) Right{} = Left m+vap Right{} (Left n) = Left n+vap (Right f) (Right a) = Right (f a)+{-# INLINE vap #-}++ealt :: Validation e a -> Validation e a -> Validation e a+ealt Failure{} r = r+ealt (Success a) _ = Success a+{-# INLINE ealt #-}

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import           Control.Applicative+import           Data.Either.Validation+import           Data.Monoid (Sum(..))++import           Data.Functor (void)+import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++-- -- empty is a neutral element+-- empty <|> u  =  u+-- u <|> empty  =  u+-- -- (<|>) is associative+-- u <|> (v <|> w)  =  (u <|> v) <|> w++genValidation :: Gen a -> Gen b -> Gen (Validation a b)+genValidation ga gb = do+  a <- ga+  b <- gb+  Gen.choice [return $ Failure a, return $ Success b]++identity :: (Eq a, Show a) => (a -> a -> a) -> a -> Gen a -> PropertyT IO ()+identity f i gen = do+  x <- forAll gen+  f x i === x+  f i x === x++assoc :: (Eq a, Show a) => (a -> a -> a) -> Gen a -> PropertyT IO ()+assoc f gen = do+  x <- forAll gen+  y <- forAll gen+  z <- forAll gen++  let xy = f x y+      yz = f y z++  f x yz === f xy z++prop_alternative :: Property+prop_alternative = property $ do+  let genSumInt = Sum <$> Gen.int (Range.linear 0 maxBound)+      genVal = genValidation genSumInt genSumInt+  identity (<|>) empty genVal+  assoc (<|>) genVal++main :: IO ()+main =+  void $ checkParallel $ Group "Test.Either" [+      ("prop_alternative", prop_alternative)+    ]