either-5.0.2/0000755000000000000000000000000007346545000011167 5ustar0000000000000000either-5.0.2/.ghci0000644000000000000000000000012507346545000012100 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h either-5.0.2/.gitignore0000644000000000000000000000043007346545000013154 0ustar0000000000000000dist dist-newstyle docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .cabal-sandbox/ cabal.sandbox.config .stack-work/ cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* either-5.0.2/.vim.custom0000644000000000000000000000137707346545000013304 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-5.0.2/CHANGELOG.markdown0000644000000000000000000000607007346545000014225 0ustar00000000000000005.0.2 [2022.05.07] ------------------ * Tweak error messages of `fromRight'` and `fromLeft'` for clarity. * Allow building with `mtl-2.3.*`. 5.0.1.1 [2019.05.02] -------------------- * Only incur a `semigroups` dependency on pre-8.0 GHCs. 5.0.1 [2018.07.03] ------------------ * Make the `Semigroup`, `Apply`, and `Applicative` instances for `Validation` lazier. * Make `vap` lazier in its second argument. * Introduce `vapm`, an even lazier version of `vap` which requires a `Monoid` constraint. Also add `apm`, a counterpart for `Validation`. * Use `test-framework` and `QuickCheck` in the test suite. 5 - * Changed the semantics of the `Validation` `Alt` and `Alternative` instances to collect errors. The previous implementation did not correctly abide the laws. * Added `vap`, for when users want validation like semantics but don't want to convert back and forth to validation all the time. Similarly, added `ealt` to give either's `Alt` semantics to validation. * Dropped the deprecated `Control.Monad.Trans.Either`. Use `Control.Monad.Trans.Except` from `transformers` and/or `transformers-compat` instead. 4.5 ---- * Add `MMonad` instance for `EitherT` * Deprecate `Control.Monad.Trans.Either` in favor of `Control.Monad.Trans.Except` * Add `firstEitherT` 4.4.1.1 ------- * Fixed building on newer GHCs. (type synonyms require explicit foralls for unused variables these days) 4.4.1 ----- * `transformers` 0.5 support * Documentation fixes 4.4 --- * Support `mmorph` 4.3.4.1 ------- * Support `MonadRandom` 0.4 4.3.4 ----- * Support `bifunctors` 5, `profunctors` 5, and `semigroupoids` 5. 4.3.3.3 ------- * Fixed and enhanced documentation for `eitherToError`. 4.3.3.2 ------- * Support `exceptions` 0.8 4.3.3.1 ------- * Support `exceptions` 0.7 4.3.3 ----- * Added `eitherToError`. 4.3.2.1 ------- * Support `monad-control` 1.0 4.3.2 ----- * Added `Validation`. 4.3.0.2 ------- * Updated MonadRandom support. 4.3.0.1 ------- * Fixed import of `MonadCatch` to support versions of `base` before 4.6 4.3 --- * Inverted dependency between `free` and `either`. 4.2 --- * Added instances for `MonadThrow`, `MonadCatch`. 4.1 --- * Added instances for `MonadBase`, `MonadBaseControl`, and `MonadTransControl`. 4.0 --- * Updated dependencies. 3.4.2 ----- * Added 'Data.Either.Combinators'. 3.4.1 ----- * Trustworthy despite UndecidableInstances 3.4 --- * Delegate `fail` to the underlying `Monad`, rather than `error`. 3.3 --- * Inverted roles between `Semigroup` and `Alt`. This let us write `Alternative` and `MonadPlus` instances that are compatible. * Removed the `Functor` constraint on most instances in exchange for incurring a `Monad` constraint on `Traversable`. `EitherT` is after all, a `Monad` transformer first and foremost. 3.2 --- * Changed the `Semigroup` to use a `Semigroup` to combine `Left` branches. Left `Alt` untouched, so you can mix and match. 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-5.0.2/LICENSE0000644000000000000000000000266007346545000012200 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-5.0.2/README.markdown0000644000000000000000000000072507346545000013674 0ustar0000000000000000either ====== [![Hackage](https://img.shields.io/hackage/v/either.svg)](https://hackage.haskell.org/package/either) [![Build Status](https://github.com/ekmett/either/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/either/actions?query=workflow%3AHaskell-CI) Contact Information ------------------- 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-5.0.2/Setup.lhs0000644000000000000000000000016507346545000013001 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain either-5.0.2/either.cabal0000644000000000000000000000361207346545000013435 0ustar0000000000000000name: either category: Control, Monads version: 5.0.2 license: BSD3 cabal-version: >= 1.10 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-2017 Edward A. Kmett synopsis: Combinators for working with sums description: Combinators for working with sums. build-type: Simple tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.4 , GHC == 9.0.1 extra-source-files: .gitignore .ghci .vim.custom 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, mtl >= 2.0 && < 2.4, profunctors >= 4 && < 6, semigroupoids >= 4 && < 6 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.8.3.1 && < 1 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, test-framework >= 0.8.1.1 && < 0.9, test-framework-quickcheck2 >= 0.3.0.3 && < 0.4, QuickCheck >= 2.9 && < 2.15 default-language: Haskell2010 either-5.0.2/src/Data/Either/0000755000000000000000000000000007346545000014047 5ustar0000000000000000either-5.0.2/src/Data/Either/Combinators.hs0000644000000000000000000001742207346545000016671 0ustar0000000000000000{-# language CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Either.Combinators -- Copyright : (c) 2010-2014 Gregory Crosswhite, Chris Done, Edward Kmett -- License : BSD-style -- -- Maintainer : ekmett@gmail.com -- Stability : provisional -- Portability : portable -- -- Functions for probing and unwrapping values inside of 'Either'. -- -- Most of these combinators are provided for pedagogical purposes and exist -- in more general forms in other libraries. To that end alternative definitions -- are supplied below. -- ----------------------------------------------------------------------------- module Data.Either.Combinators ( isLeft , isRight , fromLeft , fromRight , fromLeft' , fromRight' , mapBoth , mapLeft , mapRight , whenLeft , whenRight , unlessLeft , unlessRight , leftToMaybe , rightToMaybe , maybeToLeft , maybeToRight , eitherToError , swapEither ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad.Error.Class ( MonadError(throwError) ) -- --------------------------------------------------------------------------- -- Functions over Either -- |The 'isLeft' function returns 'True' iff its argument is of the form @'Left' _@. -- -- Using @Control.Lens@: -- -- @ -- 'isLeft' ≡ has _Left -- @ -- -- >>> isLeft (Left 12) -- True -- -- >>> isLeft (Right 12) -- False isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft _ = False -- |The 'isRight' function returns 'True' iff its argument is of the form @'Right' _@. -- -- Using @Control.Lens@: -- -- @ -- 'isRight' ≡ has _Right -- @ -- -- >>> isRight (Left 12) -- False -- -- >>> isRight (Right 12) -- True isRight :: Either a b -> Bool isRight (Right _) = True isRight _ = False -- | Extracts the element out of a 'Left' and -- throws an error if its argument take the form @'Right' _@. -- -- Using @Control.Lens@: -- -- @ -- 'fromLeft'' x ≡ x^?!_Left -- @ -- -- >>> fromLeft' (Left 12) -- 12 fromLeft' :: Either a b -> a fromLeft' (Right _) = error "Data.Either.Combinators.fromLeft' encountered a value of form 'Right _', consider using Data.Either.Combinators.fromLeft with a default value." -- yuck fromLeft' (Left x) = x -- | Extracts the element out of a 'Right' and -- throws an error if its argument take the form @'Left' _@. -- -- Using @Control.Lens@: -- -- @ -- 'fromRight'' x ≡ x^?!_Right -- @ -- -- >>> fromRight' (Right 12) -- 12 fromRight' :: Either a b -> b fromRight' (Left _) = error "Data.Either.Combinators.fromRight' encountered a value of form 'Left _', consider using Data.Either.Combinators.fromRight with a default value." -- yuck fromRight' (Right x) = x -- | The 'mapBoth' function takes two functions and applies the first if iff the value -- takes the form @'Left' _@ and the second if the value takes the form @'Right' _@. -- -- Using @Data.Bifunctor@: -- -- @ -- 'mapBoth' = bimap -- @ -- -- Using @Control.Arrow@: -- -- @ -- 'mapBoth' = ('Control.Arrow.+++') -- @ -- -- >>> mapBoth (*2) (*3) (Left 4) -- Left 8 -- -- >>> mapBoth (*2) (*3) (Right 4) -- Right 12 mapBoth :: (a -> c) -> (b -> d) -> Either a b -> Either c d mapBoth f _ (Left x) = Left (f x) mapBoth _ f (Right x) = Right (f x) -- | The 'mapLeft' function takes a function and applies it to an Either value -- iff the value takes the form @'Left' _@. -- -- Using @Data.Bifunctor@: -- -- @ -- 'mapLeft' = first -- @ -- -- Using @Control.Arrow@: -- -- @ -- 'mapLeft' = ('Control.Arrow.left') -- @ -- -- Using @Control.Lens@: -- -- @ -- 'mapLeft' = over _Left -- @ -- -- >>> mapLeft (*2) (Left 4) -- Left 8 -- -- >>> mapLeft (*2) (Right "hello") -- Right "hello" mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f = mapBoth f id -- | The 'mapRight' function takes a function and applies it to an Either value -- iff the value takes the form @'Right' _@. -- -- Using @Data.Bifunctor@: -- -- @ -- 'mapRight' = second -- @ -- -- Using @Control.Arrow@: -- -- @ -- 'mapRight' = ('Control.Arrow.right') -- @ -- -- Using @Control.Lens@: -- -- @ -- 'mapRight' = over _Right -- @ -- -- >>> mapRight (*2) (Left "hello") -- Left "hello" -- -- >>> mapRight (*2) (Right 4) -- Right 8 mapRight :: (b -> c) -> Either a b -> Either a c mapRight = mapBoth id -- | The 'whenLeft' function takes an 'Either' value and a function which returns a monad. -- The monad is only executed when the given argument takes the form @'Left' _@, otherwise -- it does nothing. -- -- Using @Control.Lens@: -- -- @ -- 'whenLeft' ≡ forOf_ _Left -- @ -- -- >>> whenLeft (Left 12) print -- 12 whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m () whenLeft (Left x) f = f x whenLeft _ _ = pure () -- | The 'whenRight' function takes an 'Either' value and a function which returns a monad. -- The monad is only executed when the given argument takes the form @'Right' _@, otherwise -- it does nothing. -- -- Using @Data.Foldable@: -- -- @ -- 'whenRight' ≡ 'forM_' -- @ -- -- Using @Control.Lens@: -- -- @ -- 'whenRight' ≡ forOf_ _Right -- @ -- -- >>> whenRight (Right 12) print -- 12 whenRight :: Applicative m => Either a b -> (b -> m ()) -> m () whenRight (Right x) f = f x whenRight _ _ = pure () -- | A synonym of 'whenRight'. unlessLeft :: Applicative m => Either a b -> (b -> m ()) -> m () unlessLeft = whenRight -- | A synonym of 'whenLeft'. unlessRight :: Applicative m => Either a b -> (a -> m ()) -> m () unlessRight = whenLeft -- | Extract the left value or a default. -- -- @ -- 'fromLeft' b ≡ 'either' 'id' ('const' b) -- @ -- -- >>> fromLeft "hello" (Right 42) -- "hello" -- -- >>> fromLeft "hello" (Left "world") -- "world" fromLeft :: a -> Either a b -> a fromLeft _ (Left x) = x fromLeft x _ = x -- | Extract the right value or a default. -- -- @ -- 'fromRight' b ≡ 'either' ('const' b) 'id' -- @ -- -- >>> fromRight "hello" (Right "world") -- "world" -- -- >>> fromRight "hello" (Left 42) -- "hello" fromRight :: b -> Either a b -> b fromRight _ (Right x) = x fromRight x _ = x -- | Maybe get the 'Left' side of an 'Either'. -- -- @ -- 'leftToMaybe' ≡ 'either' 'Just' ('const' 'Nothing') -- @ -- -- Using @Control.Lens@: -- -- @ -- 'leftToMaybe' ≡ preview _Left -- 'leftToMaybe' x ≡ x^?_Left -- @ -- -- >>> leftToMaybe (Left 12) -- Just 12 -- -- >>> leftToMaybe (Right 12) -- Nothing leftToMaybe :: Either a b -> Maybe a leftToMaybe = either Just (const Nothing) -- | Maybe get the 'Right' side of an 'Either'. -- -- @ -- 'rightToMaybe' ≡ 'either' ('const' 'Nothing') 'Just' -- @ -- -- Using @Control.Lens@: -- -- @ -- 'rightToMaybe' ≡ preview _Right -- 'rightToMaybe' x ≡ x^?_Right -- @ -- -- >>> rightToMaybe (Left 12) -- Nothing -- -- >>> rightToMaybe (Right 12) -- Just 12 rightToMaybe :: Either a b -> Maybe b rightToMaybe = either (const Nothing) Just -- | Maybe produce a 'Left', otherwise produce a 'Right'. -- -- >>> maybeToLeft "default" (Just 12) -- Left 12 -- -- >>> maybeToLeft "default" Nothing -- Right "default" maybeToLeft :: b -> Maybe a -> Either a b maybeToLeft _ (Just x) = Left x maybeToLeft y Nothing = Right y -- | Maybe produce a 'Right', otherwise produce a 'Left'. -- -- >>> maybeToRight "default" (Just 12) -- Right 12 -- -- >>> maybeToRight "default" Nothing -- Left "default" maybeToRight :: b -> Maybe a -> Either b a maybeToRight _ (Just x) = Right x maybeToRight y Nothing = Left y -- | Generalize @Either e@ as @MonadError e m@. -- -- If the argument has form @Left e@, an error is produced in the monad via -- 'throwError'. Otherwise, the @Right a@ part is forwarded. eitherToError :: (MonadError e m) => Either e a -> m a eitherToError = either throwError return -- | Swap the 'Left' and 'Right' sides of an 'Either'. -- -- >>> swapEither (Right 3) -- Left 3 -- -- >>> swapEither (Left "error") -- Right "error" swapEither :: Either e a -> Either a e swapEither = either Right Left {-# INLINE swapEither #-} either-5.0.2/src/Data/Either/Validation.hs0000644000000000000000000001260107346545000016475 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Either.Validation -- Copyright : (c) 2014 Chris Allen, Edward Kmett -- License : BSD-style -- -- Maintainer : ekmett@gmail.com -- Stability : provisional -- Portability : portable -- -- Monoidal 'Validation' sibling to 'Either'. -- ----------------------------------------------------------------------------- module Data.Either.Validation ( Validation(..) , _Success , _Failure , eitherToValidation , validationToEither , _Validation , vap , ealt -- combinators that leak less, but require monoid constraints , vapm, apm ) where import Control.Applicative import Data.Bifoldable(Bifoldable(bifoldr)) import Data.Bifunctor(Bifunctor(bimap)) import Data.Bitraversable(Bitraversable(bitraverse)) import Data.Foldable (Foldable(foldr)) import Data.Functor.Alt (Alt(())) import Data.Functor.Apply (Apply ((<.>))) import Data.Profunctor import Prelude hiding (foldr) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Traversable (Traversable(traverse)) #endif #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif -- | 'Validation' is 'Either' with a Left that is a 'Monoid' data Validation e a = Failure e | Success a deriving (Eq, Ord, Show) instance Functor (Validation e) where fmap _ (Failure e) = Failure e fmap f (Success a) = Success (f a) instance Semigroup e => Apply (Validation e) where Failure e1 <.> b = Failure $ case b of Failure e2 -> e1 <> e2 Success _ -> e1 Success _ <.> Failure e = Failure e Success f <.> Success x = Success (f x) instance Semigroup e => Applicative (Validation e) where pure = Success (<*>) = (<.>) -- | For two errors, this instance reports both of them. instance Semigroup e => Alt (Validation e) where s@Success{} _ = s _ s@Success{} = s Failure m Failure n = Failure (m <> n) instance (Semigroup e, Monoid e) => Alternative (Validation e) where empty = Failure mempty (<|>) = () instance Foldable (Validation e) where foldr f x (Success a) = f a x foldr _ x (Failure _) = x instance Traversable (Validation e) where traverse f (Success a) = Success <$> f a traverse _ (Failure e) = pure (Failure e) instance Bifunctor Validation where bimap f _ (Failure e) = Failure (f e) bimap _ g (Success a) = Success (g a) instance Bifoldable Validation where bifoldr _ g x (Success a) = g a x bifoldr f _ x (Failure e) = f e x instance Bitraversable Validation where bitraverse _ g (Success a) = Success <$> g a bitraverse f _ (Failure e) = Failure <$> f e instance Semigroup e => Semigroup (Validation e a) where x@Success{} <> _ = x _ <> x@Success{} = x Failure e1 <> Failure e2 = Failure (e1 <> e2) instance Monoid e => Monoid (Validation e a) where mempty = Failure mempty #if !(MIN_VERSION_base(4,11,0)) x@Success{} `mappend` _ = x _ `mappend` x@Success{} = x Failure e1 `mappend` Failure e2 = Failure (e1 `mappend` e2) #endif type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt seta = dimap seta (either pure (fmap bt)) . right' {-# INLINE prism #-} _Failure :: Prism (Validation a c) (Validation b c) a b _Failure = prism (\ x -> Failure x) (\ x -> case x of Failure y -> Right y Success y -> Left (Success y)) {-# INLINE _Failure #-} _Success :: Prism (Validation c a) (Validation c b) a b _Success = prism (\ x -> Success x) (\ x -> case x of Failure y -> Left (Failure y) Success y -> Right y) {-# INLINE _Success #-} type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) {-# INLINE iso #-} validationToEither :: Validation e a -> Either e a validationToEither x = case x of Failure e -> Left e Success a -> Right a {-# INLINE validationToEither #-} eitherToValidation :: Either e a -> Validation e a eitherToValidation x = case x of Left e -> Failure e Right a -> Success a {-# INLINE eitherToValidation #-} -- | 'Validation' is isomorphic to 'Either' _Validation :: Iso (Validation e a) (Validation g b) (Either e a) (Either g b) _Validation = iso validationToEither eitherToValidation {-# INLINE _Validation #-} vap :: Semigroup m => Either m (a -> b) -> Either m a -> Either m b vap (Left m) b = Left $ case b of Left n -> m <> n Right{} -> m vap Right{} (Left n) = Left n vap (Right f) (Right a) = Right (f a) {-# INLINE vap #-} apm :: Monoid m => Validation m (a -> b) -> Validation m a -> Validation m b apm (Failure m) b = Failure $ m `mappend` case b of Failure n -> n Success{} -> mempty apm Success{} (Failure n) = Failure n apm (Success f) (Success a) = Success (f a) {-# INLINE apm #-} -- lazier version of vap that can leak less, but which requires a Monoid vapm :: Monoid m => Either m (a -> b) -> Either m a -> Either m b vapm (Left m) b = Left $ m `mappend` case b of Left n -> n Right{} -> mempty vapm Right{} (Left n) = Left n vapm (Right f) (Right a) = Right (f a) {-# INLINE vapm #-} ealt :: Validation e a -> Validation e a -> Validation e a ealt Failure{} r = r ealt (Success a) _ = Success a {-# INLINE ealt #-} either-5.0.2/tests/0000755000000000000000000000000007346545000012331 5ustar0000000000000000either-5.0.2/tests/Main.hs0000644000000000000000000000277307346545000013562 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Applicative import Data.Either.Validation import Data.Monoid (Sum(..)) import Test.QuickCheck (Property, Gen, (===), (.&&.), Arbitrary (..), forAllShrink, oneof) import Test.Framework (defaultMain) import Test.Framework.Providers.QuickCheck2 (testProperty) main :: IO () main = defaultMain [ testProperty "identity" $ identity (<|>) empty genValSumInt shrinkValidation , testProperty "associativity" $ associativity (<|>) genValSumInt shrinkValidation ] genValSumInt :: Gen (Validation (Sum Int) (Sum Int)) genValSumInt = genValidation genValidation :: (Arbitrary a, Arbitrary b) => Gen (Validation a b) genValidation = oneof [ fmap Failure arbitrary , fmap Success arbitrary ] shrinkValidation :: (Arbitrary a, Arbitrary b) => Validation a b -> [Validation a b] shrinkValidation (Success x) = Success `fmap` shrink x shrinkValidation (Failure x) = Failure `fmap` shrink x -- -- empty is a neutral element -- empty <|> u = u -- u <|> empty = u -- -- (<|>) is associative -- u <|> (v <|> w) = (u <|> v) <|> w identity :: (Eq a, Show a) => (a -> a -> a) -> a -> Gen a -> (a -> [a]) -> Property identity f i gen shr = forAllShrink gen shr $ \x -> f x i === x .&&. f i x === x associativity :: (Eq a, Show a) => (a -> a -> a) -> Gen a -> (a -> [a]) -> Property associativity f gen shr = forAllShrink gen shr $ \x -> forAllShrink gen shr $ \y -> forAllShrink gen shr $ \z -> f x (f y z) === f (f x y) z