Hello community,
here is the log from the commit of package ghc-either for openSUSE:Factory
checked in at 2018-05-30 12:07:07
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-either (Old)
and /work/SRC/openSUSE:Factory/.ghc-either.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-either"
Wed May 30 12:07:07 2018 rev:9 rq:607792 version:5
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-either/ghc-either.changes 2017-09-15
21:37:23.491278756 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-either.new/ghc-either.changes
2018-05-30 12:25:35.101778317 +0200
@@ -1,0 +2,13 @@
+Mon May 14 17:02:11 UTC 2018 - psim...@suse.com
+
+- Update either to version 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.
+ * Add `MMonad` instance for `EitherT`
+ * Deprecate `Control.Monad.Trans.Either` in favor of
`Control.Monad.Trans.Except`
+ * Add `firstEitherT`
+
+-------------------------------------------------------------------
Old:
----
either-4.4.1.1.tar.gz
either.cabal
New:
----
either-5.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-either.spec ++++++
--- /var/tmp/diff_new_pack.PkpGKd/_old 2018-05-30 12:25:35.981749258 +0200
+++ /var/tmp/diff_new_pack.PkpGKd/_new 2018-05-30 12:25:35.985749126 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-either
#
-# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -17,32 +17,28 @@
%global pkg_name either
+%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 4.4.1.1
+Version: 5
Release: 0
-Summary: An either monad transformer
+Summary: Combinators for working with sums
License: BSD-3-Clause
Group: Development/Libraries/Haskell
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/2.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
-BuildRequires: ghc-MonadRandom-devel
BuildRequires: ghc-bifunctors-devel
-BuildRequires: ghc-exceptions-devel
-BuildRequires: ghc-free-devel
-BuildRequires: ghc-mmorph-devel
-BuildRequires: ghc-monad-control-devel
BuildRequires: ghc-mtl-devel
BuildRequires: ghc-profunctors-devel
BuildRequires: ghc-rpm-macros
BuildRequires: ghc-semigroupoids-devel
BuildRequires: ghc-semigroups-devel
-BuildRequires: ghc-transformers-base-devel
-BuildRequires: ghc-transformers-devel
+%if %{with tests}
+BuildRequires: ghc-hedgehog-devel
+%endif
%description
-An either monad transformer.
+Combinators for working with sums.
%package devel
Summary: Haskell %{pkg_name} library development files
@@ -57,7 +53,6 @@
%prep
%setup -q -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
@@ -65,6 +60,9 @@
%install
%ghc_lib_install
+%check
+%cabal_test
+
%post devel
%ghc_pkg_recache
@@ -72,7 +70,7 @@
%ghc_pkg_recache
%files -f %{name}.files
-%doc LICENSE
+%license LICENSE
%files devel -f %{name}-devel.files
%doc CHANGELOG.markdown README.markdown
++++++ either-4.4.1.1.tar.gz -> either-5.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/.gitignore new/either-5/.gitignore
--- old/either-4.4.1.1/.gitignore 2016-05-10 01:31:19.000000000 +0200
+++ new/either-5/.gitignore 2017-11-21 04:04:46.000000000 +0100
@@ -11,3 +11,5 @@
*.hi
*~
*#
+.cabal-sandbox/
+cabal.sandbox.config
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/.travis.yml new/either-5/.travis.yml
--- old/either-4.4.1.1/.travis.yml 2016-05-10 01:31:19.000000000 +0200
+++ new/either-5/.travis.yml 2017-11-21 04:04:46.000000000 +0100
@@ -1,8 +1,104 @@
-language: haskell
+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
+language: c
+sudo: false
+
+cache:
+ directories:
+ - $HOME/.cabsnap
+ - $HOME/.cabal/packages
+
+before_cache:
+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
+
+matrix:
+ include:
+ - env: CABALVER=1.18 GHCVER=7.4.2
+ compiler: ": #GHC 7.4.2"
+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources:
[hvr-ghc]}}
+ - env: CABALVER=1.18 GHCVER=7.6.3
+ compiler: ": #GHC 7.6.3"
+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources:
[hvr-ghc]}}
+ - env: CABALVER=1.18 GHCVER=7.8.4
+ compiler: ": #GHC 7.8.4"
+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources:
[hvr-ghc]}}
+ - env: CABALVER=1.22 GHCVER=7.10.3
+ compiler: ": #GHC 7.10.3"
+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources:
[hvr-ghc]}}
+ - env: CABALVER=1.24 GHCVER=8.0.2
+ compiler: ": #GHC 8.0.2"
+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources:
[hvr-ghc]}}
+ - env: CABALVER=2.0 GHCVER=8.2.1
+ compiler: ": #GHC 8.2.1"
+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources:
[hvr-ghc]}}
+ - env: CABALVER=head GHCVER=head
+ compiler: ": #GHC head"
+ addons: {apt: {packages: [cabal-install-head,ghc-head], sources:
[hvr-ghc]}}
+
+ allow_failures:
+ - env: CABALVER=head GHCVER=head
+
+before_install:
+ - unset CC
+ - export
PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+install:
+ - cabal --version
+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null ||
echo '?')]"
+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
+ then
+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
+ fi
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - cabal install --only-dependencies --dry -v > installplan.txt
+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
+
+# check whether current requested install-plan matches cached package-db
snapshot
+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
+ then
+ echo "cabal build-cache HIT";
+ rm -rfv .ghc;
+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin
$HOME/.cabal/;
+ else
+ echo "cabal build-cache MISS";
+ rm -rf $HOME/.cabsnap;
+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
+ cabal install -j --only-dependencies;
+ fi
+
+# snapshot package-db on cache miss
+ - if [ ! -d $HOME/.cabsnap ];
+ then
+ echo "snapshotting package-db to build-cache";
+ mkdir $HOME/.cabsnap;
+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin
installplan.txt $HOME/.cabsnap/;
+ fi
+
+# Here starts the actual work to be performed for the package under test;
+# any command which exits with a non-zero exit code causes the build to fail.
+script:
+ - cabal configure -v2 # -v2 provides useful information for debugging
+ - cabal build # this builds all libraries and executables (including
tests/benchmarks)
+ - cabal sdist # tests that a source-distribution can be generated
+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
+ cd dist/;
+ if [ -f "$SRC_TGZ" ]; then
+ cabal install "$SRC_TGZ";
+ else
+ echo "expected '$SRC_TGZ' not found";
+ exit 1;
+ fi
+
notifications:
irc:
channels:
- "irc.freenode.org#haskell-lens"
skip_join: true
template:
- - "\x0313either\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url}
%{message}"
+ - "\x0313either\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message}
\x0302\x1f%{build_url}\x0f"
+
+# EOF
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/CHANGELOG.markdown
new/either-5/CHANGELOG.markdown
--- old/either-4.4.1.1/CHANGELOG.markdown 2016-05-10 01:31:19.000000000
+0200
+++ new/either-5/CHANGELOG.markdown 2017-11-21 04:04:46.000000000 +0100
@@ -1,3 +1,17 @@
+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)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/either.cabal new/either-5/either.cabal
--- old/either-4.4.1.1/either.cabal 2016-05-10 01:31:19.000000000 +0200
+++ new/either-5/either.cabal 2017-11-21 04:04:46.000000000 +0100
@@ -1,17 +1,17 @@
name: either
category: Control, Monads
-version: 4.4.1.1
+version: 5
license: BSD3
-cabal-version: >= 1.6
+cabal-version: >= 1.10
license-file: LICENSE
author: Edward A. Kmett
maintainer: Edward A. Kmett <ekm...@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.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.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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/src/Control/Monad/Trans/Either.hs
new/either-5/src/Control/Monad/Trans/Either.hs
--- old/either-4.4.1.1/src/Control/Monad/Trans/Either.hs 2016-05-10
01:31:19.000000000 +0200
+++ new/either-5/src/Control/Monad/Trans/Either.hs 1970-01-01
01:00:00.000000000 +0100
@@ -1,360 +0,0 @@
-{-# 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 <ekm...@gmail.com>
--- Stability : provisional
--- Portability : MPTCs
---
--- This module provides a minimalist 'Either' monad transformer.
------------------------------------------------------------------------------
-
-module Control.Monad.Trans.Either
- ( EitherT(..)
- , eitherT
- , bimapEitherT
- , mapEitherT
- , hoistEither
- , bracketEitherT
- , bracketEitherT_
- , left
- , right
- , swapEitherT
- ) where
-
-import Control.Applicative
-import Control.Monad (liftM, MonadPlus(..))
-import Control.Monad.Base (MonadBase(..), liftBaseDefault)
-import Control.Monad.Cont.Class
-import Control.Monad.Error.Class
-import Control.Monad.Free.Class
-import Control.Monad.Catch as MonadCatch
-import Control.Monad.Fix
-import Control.Monad.IO.Class
-import Control.Monad.Reader.Class
-import Control.Monad.State (MonadState,get,put)
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Control (MonadBaseControl(..),
MonadTransControl(..), defaultLiftBaseWith, defaultRestoreM)
-import Control.Monad.Writer.Class
-import Control.Monad.Random
(MonadRandom,getRandom,getRandoms,getRandomR,getRandomRs)
-import 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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/src/Data/Either/Combinators.hs
new/either-5/src/Data/Either/Combinators.hs
--- old/either-4.4.1.1/src/Data/Either/Combinators.hs 2016-05-10
01:31:19.000000000 +0200
+++ new/either-5/src/Data/Either/Combinators.hs 2017-11-21 04:04:46.000000000
+0100
@@ -1,3 +1,4 @@
+{-# language CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Either.Combinators
@@ -32,11 +33,15 @@
, unlessRight
, leftToMaybe
, rightToMaybe
+ , maybeToLeft
+ , maybeToRight
, eitherToError
, swapEither
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Error.Class ( MonadError(throwError) )
-- ---------------------------------------------------------------------------
@@ -306,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@.
--
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/src/Data/Either/Validation.hs
new/either-5/src/Data/Either/Validation.hs
--- old/either-4.4.1.1/src/Data/Either/Validation.hs 2016-05-10
01:31:19.000000000 +0200
+++ new/either-5/src/Data/Either/Validation.hs 2017-11-21 04:04:46.000000000
+0100
@@ -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 #-}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/either-4.4.1.1/tests/Main.hs
new/either-5/tests/Main.hs
--- old/either-4.4.1.1/tests/Main.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/either-5/tests/Main.hs 2017-11-21 04:04:46.000000000 +0100
@@ -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)
+ ]
