either 5 → 5.0.3
raw patch · 8 files changed
Files
- .gitignore +17/−0
- .travis.yml +0/−104
- CHANGELOG.markdown +23/−0
- README.markdown +1/−3
- either.cabal +24/−8
- src/Data/Either/Combinators.hs +4/−10
- src/Data/Either/Validation.hs +39/−15
- tests/Main.hs +36/−41
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -13,3 +14,19 @@ *# .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,104 +0,0 @@-# 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\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"--# EOF
CHANGELOG.markdown view
@@ -1,3 +1,26 @@+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.
README.markdown view
@@ -1,9 +1,7 @@ either ====== -[](https://hackage.haskell.org/package/either) [](http://travis-ci.org/ekmett/either)--This provides an `Either` monad transformer that unlike `ErrorT` is unencumbered by a constraint on its `Left` hand argument. This is needed for a number of applications of this monad transformer, notably in [recursion-schemes](https://github.com/ekmett/recursion-schemes).+[](https://hackage.haskell.org/package/either) [](https://github.com/ekmett/either/actions?query=workflow%3AHaskell-CI) Contact Information -------------------
either.cabal view
@@ -1,6 +1,6 @@ name: either category: Control, Monads-version: 5+version: 5.0.3 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -13,26 +13,37 @@ 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,+ base >= 4.9 && < 5, bifunctors >= 4 && < 6,- mtl >= 2.0 && < 2.3,+ mtl >= 2.0 && < 2.4, profunctors >= 4 && < 6,- semigroups >= 0.8.3.1 && < 1,- semigroupoids >= 4 && < 6+ semigroupoids >= 4 && < 7 other-extensions: CPP Rank2Types ghc-options: -Wall@@ -47,5 +58,10 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests- build-depends: base, either, hedgehog+ build-depends:+ base,+ either,+ tasty >= 1.4 && < 1.6,+ tasty-quickcheck >= 0.10 && < 0.12,+ QuickCheck >= 2.9 && < 2.17 default-language: Haskell2010
src/Data/Either/Combinators.hs view
@@ -1,4 +1,3 @@-{-# language CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Either.Combinators@@ -39,9 +38,6 @@ , swapEither ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Control.Monad.Error.Class ( MonadError(throwError) ) -- ---------------------------------------------------------------------------@@ -93,7 +89,7 @@ -- >>> fromLeft' (Left 12) -- 12 fromLeft' :: Either a b -> a-fromLeft' (Right _) = error "Data.Either.Combinators.fromLeft: Argument takes form 'Right _'" -- yuck+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@@ -108,7 +104,7 @@ -- >>> fromRight' (Right 12) -- 12 fromRight' :: Either a b -> b-fromRight' (Left _) = error "Data.Either.Combinators.fromRight: Argument takes form 'Left _'" -- yuck+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@@ -313,10 +309,10 @@ -- | Maybe produce a 'Left', otherwise produce a 'Right'. ----- >>> maybeToRight "default" (Just 12)+-- >>> maybeToLeft "default" (Just 12) -- Left 12 ----- >>> maybeToRight "default" Nothing+-- >>> maybeToLeft "default" Nothing -- Right "default" maybeToLeft :: b -> Maybe a -> Either a b maybeToLeft _ (Just x) = Left x@@ -342,13 +338,11 @@ -- | 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
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -----------------------------------------------------------------------------@@ -23,6 +24,8 @@ , _Validation , vap , ealt+ -- combinators that leak less, but require monoid constraints+ , vapm, apm ) where import Control.Applicative@@ -32,12 +35,13 @@ 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((<>)))-import Data.Traversable (Traversable(traverse)) 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@@ -49,15 +53,17 @@ 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)+ 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@@ -88,17 +94,17 @@ 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)- 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+#if !(MIN_VERSION_base(4,11,0))+ x@Success{} `mappend` _ = x+ _ `mappend` x@Success{} = x 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+#endif type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) @@ -148,11 +154,29 @@ {-# 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 (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
tests/Main.hs view
@@ -2,53 +2,48 @@ module Main where -import Control.Applicative-import Data.Either.Validation-import Data.Monoid (Sum(..))+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+import Test.QuickCheck (Property, Gen, (===), (.&&.), Arbitrary (..), forAllShrink, oneof)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty) --- -- 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]+main :: IO ()+main = defaultMain $+ testGroup "either"+ [ testProperty "identity" $ identity (<|>) empty genValSumInt shrinkValidation+ , testProperty "associativity" $ associativity (<|>) genValSumInt shrinkValidation+ ] -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+genValSumInt :: Gen (Validation (Sum Int) (Sum Int))+genValSumInt = genValidation -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+genValidation :: (Arbitrary a, Arbitrary b) => Gen (Validation a b)+genValidation = oneof+ [ fmap Failure arbitrary+ , fmap Success arbitrary+ ] - let xy = f x y- yz = f y z+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 - f x yz === f xy z+-- -- empty is a neutral element+-- empty <|> u = u+-- u <|> empty = u+-- -- (<|>) is associative+-- u <|> (v <|> w) = (u <|> v) <|> w -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+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 -main :: IO ()-main =- void $ checkParallel $ Group "Test.Either" [- ("prop_alternative", prop_alternative)- ]+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