exitcode 0.1.0.2 → 0.1.0.3
raw patch · 4 files changed
+303/−160 lines, 4 filesdep ~basedep ~lensdep ~transformersnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, lens, transformers
API changes (from Hackage documentation)
- Control.Exitcode: instance (Data.Functor.Bind.Class.Bind f, GHC.Base.Monad f) => Data.Functor.Bind.Class.Bind (Control.Exitcode.ExitcodeT f)
- Control.Exitcode: instance Data.Functor.Bind.Class.Apply f => Data.Functor.Bind.Class.Apply (Control.Exitcode.ExitcodeT f)
- Control.Exitcode: instance Data.Semigroup.Foldable.Class.Foldable1 f => Data.Semigroup.Foldable.Class.Foldable1 (Control.Exitcode.ExitcodeT f)
- Control.Exitcode: instance GHC.Base.Applicative f => Data.Functor.Extend.Extend (Control.Exitcode.ExitcodeT f)
- Control.Exitcode: instance GHC.Base.Applicative f => GHC.Base.Applicative (Control.Exitcode.ExitcodeT f)
+ Control.Exitcode: fromExitCode' :: ExitCode -> Exitcode0
+ Control.Exitcode: fromExitCodeValue :: Applicative f => Int -> a -> ExitcodeT f a
+ Control.Exitcode: fromExitCodeValue' :: Applicative f => Int -> ExitcodeT0 f
+ Control.Exitcode: instance Data.Functor.Extend.Extend f => Data.Functor.Extend.Extend (Control.Exitcode.ExitcodeT f)
+ Control.Exitcode: instance GHC.Base.Monad f => Data.Functor.Bind.Class.Apply (Control.Exitcode.ExitcodeT f)
+ Control.Exitcode: instance GHC.Base.Monad f => Data.Functor.Bind.Class.Bind (Control.Exitcode.ExitcodeT f)
+ Control.Exitcode: instance GHC.Base.Monad f => GHC.Base.Applicative (Control.Exitcode.ExitcodeT f)
Files
- changelog.md +6/−0
- exitcode.cabal +24/−24
- src/Control/Exitcode.hs +271/−134
- test/Tests.hs +2/−2
changelog.md view
@@ -1,3 +1,9 @@+0.1.0.3++* Fix bug in `Extend` instance.+* Remove `Extend` instance.+* Add more constructor functions.+ 0.1.0.2 * `_ExitSuccess` more polymorphic.
exitcode.cabal view
@@ -1,54 +1,54 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: exitcode-version: 0.1.0.2+version: 0.1.0.3 synopsis: Monad transformer for exit codes-description: - <<http://i.imgur.com/uZnp9ke.png>>+description:+ <<https://system-f.gitlab.io/logo/systemf-450x450.jpg>> . Monad transformer for exit codes license: BSD3 license-file: LICENCE author: Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>-maintainer: Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>-copyright: Copyright (C) 2017,2018 Commonwealth Scientific and Industrial Research Organisation (CSIRO)+maintainer: Tony Morris <oᴉ˙ldɟb@llǝʞsɐɥ>+copyright: Copyright (C) 2019-2022 Tony Morris category: Control build-type: Simple extra-source-files: changelog.md cabal-version: >=1.10-homepage: https://github.com/qfpl/exitcode-bug-reports: https://github.com/qfpl/exitcode/issues+homepage: https://github.com/system-f/exitcode+bug-reports: https://github.com/system-f/exitcode/issues tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 source-repository head type: git- location: git@github.com:qfpl/exitcode.git+ location: git@github.com:system-f/exitcode.git library exposed-modules: Control.Exitcode- build-depends: base >=4.8 && <4.13- , lens >=4.15 && < 4.18+ build-depends: base >= 4.8 && < 6+ , lens >= 4.15 && < 6 , mmorph >= 1.0 && < 1.2- , mtl >=2.2 && <2.3- , semigroupoids >=5.1 && <5.4- , semigroups >=0.16 && <0.19- , transformers >=0.4.1 && <5.5+ , mtl >= 2.2 && < 2.3+ , semigroupoids >= 5.1 && < 5.4+ , semigroups >= 0.16 && < 0.19+ , transformers >= 0.5.0 && < 5.5 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall test-suite tests- build-depends: QuickCheck >=2.9.2 && <2.13- , base >=4.8 && <4.13- , checkers >=0.4.6 && <0.5+ build-depends: QuickCheck >= 2.9.2 && < 2.13+ , base >= 4.8 && < 6+ , checkers >= 0.4.6 && < 0.5 , exitcode- , hedgehog >=0.5 && <0.7- , lens >=4.15 && <4.18- , tasty >=0.11 && <1.3- , tasty-hunit >=0.9 && <0.11- , tasty-hedgehog >= 0.1 && <0.3- , tasty-quickcheck >=0.8.4 && <0.11- , transformers >=0.4.1 && <5.5+ , hedgehog >= 0.5 && < 0.7+ , lens >= 4.15 && < 6+ , tasty >= 0.11 && < 1.3+ , tasty-hunit >= 0.9 && < 0.11+ , tasty-hedgehog >= 0.1 && < 0.3+ , tasty-quickcheck >= 0.8.4 && < 0.11+ , transformers >= 0.5.0 && < 5.5 type: exitcode-stdio-1.0 main-is: Tests.hs hs-source-dirs: test
src/Control/Exitcode.hs view
@@ -1,77 +1,89 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-} module Control.Exitcode (- -- * Types- ExitcodeT- , Exitcode- , ExitcodeT0- , Exitcode0- -- * Construction- , exitsuccess- , exitsuccess0- , exitfailure0- , fromExitCode- -- * Extraction- , runExitcode- -- * Optics- , exitCode- , _ExitFailure- , _ExitSuccess- ) where+-- * Types+ ExitcodeT+, Exitcode+, ExitcodeT0+, Exitcode0+-- * Construction+, exitsuccess+, exitsuccess0+, exitfailure0+, fromExitCode+, fromExitCode'+, fromExitCodeValue+, fromExitCodeValue'+-- * Extraction+, runExitcode+-- * Optics+, exitCode+, _ExitFailure+, _ExitSuccess+) where -import Control.Applicative (Applicative(pure, (<*>)), liftA2)-import Control.Category ((.))-import Control.Lens (Iso, Prism', Prism, iso, prism', prism, view, over,- (^?), _Left)-import Control.Monad (Monad(return, (>>=)))-import Control.Monad.Cont.Class (MonadCont (..))-import Control.Monad.Error.Class (MonadError (..))-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Morph (MFunctor(hoist), MMonad(embed))-import Control.Monad.Reader (MonadReader (ask, local))-import Control.Monad.RWS.Class (MonadRWS)-import Control.Monad.State.Lazy (MonadState (get, put))-import Control.Monad.Trans.Class (MonadTrans (lift))-import Control.Monad.Trans.Maybe (MaybeT (MaybeT))-import Control.Monad.Writer.Class (MonadWriter (listen, pass, tell, writer))-import Data.Either (Either(Left, Right), either)-import Data.Eq (Eq((==)))-import Data.Foldable (Foldable(foldr))-import Data.Function (($), const, flip)-import Data.Functor (Functor(fmap), (<$>))-import Data.Functor.Alt (Alt, (<!>))-import Data.Functor.Apply (Apply, liftF2, (<.>))-import Data.Functor.Bind (Bind, (>>-))-# if MIN_VERSION_transformers(0,5,0)-import Data.Functor.Classes (Eq1, Ord1, Show1, compare1, eq1,+import Control.Applicative+ ( Applicative((<*>), liftA2, pure) )+import Control.Category ( Category((.)) )+import Control.Lens+ ( (^?),+ view,+ iso,+ _Left,+ prism,+ prism',+ over,+ Iso,+ Prism,+ Prism' )+import Control.Monad ( join, Monad(return, (>>=)) )+import Control.Monad.Cont.Class ( MonadCont(..) )+import Control.Monad.Error.Class ( MonadError(..) )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Morph+ ( MFunctor(..), MMonad(..) )+import Control.Monad.Reader ( MonadReader(ask, local) )+import Control.Monad.RWS.Class+ ( MonadRWS )+import Control.Monad.State.Lazy+ ( MonadState(get, put) )+import Control.Monad.Trans.Class ( MonadTrans(..) )+import Control.Monad.Trans.Maybe ( MaybeT(MaybeT) )+import Control.Monad.Writer.Class ( MonadWriter(..) )+import Data.Bool+import Data.Either ( Either(..), either )+import Data.Eq ( Eq((==)) )+import Data.Foldable ( Foldable(foldr) )+import Data.Function ( ($), const, flip )+import Data.Functor ( Functor(fmap), (<$>) )+import Data.Functor.Alt ( Alt((<!>)) )+import Data.Functor.Apply ( Apply((<.>)) )+import Data.Functor.Bind ( Bind((>>-)) )+import Data.Functor.Classes (Eq1, Ord1, Show1, compare1, eq1, liftCompare, liftEq, liftShowList, liftShowsPrec, showsPrec1, showsUnaryWith)-# else-import Data.Functor.Classes (Eq1, Ord1, Show1, compare1, eq1,- showsPrec1, showsUnary1)-# endif-import Data.Functor.Extend (Extend, duplicated)-import Data.Functor.Identity (Identity (Identity))-import Data.Int (Int)-import Data.Maybe (Maybe(Just, Nothing), fromMaybe)-import Data.Ord (Ord(compare))-import Data.Semigroup (Semigroup, (<>))-import Data.Semigroup.Foldable (Foldable1)-import Data.Traversable (Traversable(traverse))-import Data.Tuple (uncurry)-import Prelude (Show(showsPrec))-import System.Exit (ExitCode (ExitFailure, ExitSuccess))+import Data.Functor.Extend ( Extend(..) )+import Data.Functor.Identity ( Identity(Identity) )+import Data.Int ( Int )+import Data.Maybe ( Maybe(Nothing, Just), fromMaybe )+import Data.Ord ( Ord(compare) )+import Data.Semigroup ( Semigroup((<>)) )+import Data.Traversable ( Traversable(traverse) )+import Data.Tuple ( uncurry )+import GHC.Show ( Show(showsPrec) )+import System.Exit ( ExitCode(..) ) -- | An exit code status where failing with a value `0` cannot be represented. -- -- Transformer for either a non-zero exit code (`Int`) or a value :: `a`.-data ExitcodeT f a =+newtype ExitcodeT f a = ExitcodeT (f (Either Int a)) type Exitcode a =@@ -84,6 +96,9 @@ Exitcode () -- | Construct a succeeding exit code with the given value.+--+-- >>> exitsuccess "abc" :: ExitcodeT Identity String+-- ExitcodeT (Identity (Right "abc")) exitsuccess :: Applicative f => a@@ -92,6 +107,9 @@ ExitcodeT . pure . Right -- | Construct a succeeding exit code with unit.+--+-- >>> exitsuccess0 :: ExitcodeT0 Identity+-- ExitcodeT (Identity (Right ())) exitsuccess0 :: Applicative f => ExitcodeT0 f@@ -101,6 +119,9 @@ -- | Construct a failing exit code with the given status. -- -- If the given status is `0` then the exit code will succeed with unit.+--+-- >>> exitfailure0 99 :: ExitcodeT0 Identity+-- ExitcodeT (Identity (Left 99)) exitfailure0 :: Applicative f => Int@@ -112,6 +133,12 @@ else ExitcodeT . pure . Left $ n +-- | From base exitcode.+--+-- >>> fromExitCode (Identity ExitSuccess)+-- ExitcodeT (Identity (Right ()))+-- >>> fromExitCode (Identity (ExitFailure 99))+-- ExitcodeT (Identity (Left 99)) fromExitCode :: Functor f => f ExitCode@@ -120,6 +147,51 @@ let ExitcodeT (MaybeT r) = view exitCode x in ExitcodeT (fromMaybe (Right ()) <$> r) +-- | From base exitcode.+--+-- >>> fromExitCode' ExitSuccess+-- ExitcodeT (Identity (Right ()))+-- >>> fromExitCode' (ExitFailure 99)+-- ExitcodeT (Identity (Left 99))+-- >>> fromExitCode' (ExitFailure 0)+-- ExitcodeT (Identity (Right ()))+fromExitCode' ::+ ExitCode+ -> Exitcode0+fromExitCode' =+ fromExitCode . Identity++-- |+--+-- >>> fromExitCodeValue 99 "abc" :: ExitcodeT Identity String+-- ExitcodeT (Identity (Left 99))+-- >>> fromExitCodeValue 0 "abc" :: ExitcodeT Identity String+-- ExitcodeT (Identity (Right "abc"))+fromExitCodeValue ::+ Applicative f =>+ Int+ -> a+ -> ExitcodeT f a+fromExitCodeValue n a =+ ExitcodeT (pure (bool (Left n) (Right a) (n == 0)))++fromExitCodeValue' ::+ Applicative f =>+ Int+ -> ExitcodeT0 f+fromExitCodeValue' n =+ fromExitCodeValue n ()++-- | Isomorphism from base exitcode to underlying `Maybe (Either Int ())` where `Int` is non-zero.+--+-- >>> view exitCode (Identity (ExitFailure 99))+-- ExitcodeT (MaybeT (Identity (Just (Left 99))))+-- >>> view exitCode (Identity ExitSuccess)+-- ExitcodeT (MaybeT (Identity (Just (Right ()))))+-- >>> review exitCode (exitfailure0 99) :: Identity ExitCode+-- Identity (ExitFailure 99)+-- >>> review exitCode exitsuccess0 :: Identity ExitCode+-- Identity ExitSuccess exitCode :: (Functor f, Functor g) => Iso@@ -129,27 +201,41 @@ (ExitcodeT0 (MaybeT g)) exitCode = iso- (\x -> ExitcodeT (MaybeT ((\e -> case e of- ExitSuccess ->- Just (Right ())- ExitFailure 0 ->- Nothing- ExitFailure n ->- Just (Left n)) <$> x)))- (\(ExitcodeT (MaybeT x)) -> (\e -> case e of- Just (Right ()) ->- ExitSuccess- Nothing ->- ExitFailure 0- Just (Left n) ->- ExitFailure n) <$> x)+ (\x -> ExitcodeT (MaybeT ((\case+ ExitSuccess ->+ Just (Right ())+ ExitFailure 0 ->+ Nothing+ ExitFailure n ->+ Just (Left n)) <$> x)))+ (\(ExitcodeT (MaybeT x)) -> (\case+ Just (Right ()) ->+ ExitSuccess+ Nothing ->+ ExitFailure 0+ Just (Left n) ->+ ExitFailure n) <$> x) +-- | Extract either the non-zero value or the success value.+--+-- >>> runExitcode exitsuccess0 :: Identity (Either Int ())+-- Identity (Right ())+-- >>> runExitcode (exitfailure0 99) :: Identity (Either Int ())+-- Identity (Left 99) runExitcode :: ExitcodeT f a -> f (Either Int a) runExitcode (ExitcodeT x) = x +-- | A prism to exit failure.+--+-- >>> preview _ExitFailure (exitfailure0 99)+-- Just 99+-- >>> preview _ExitFailure exitsuccess0+-- Nothing+-- >>> review _ExitFailure 99+-- ExitcodeT (Identity (Left 99)) _ExitFailure :: Prism' Exitcode0@@ -159,6 +245,14 @@ exitfailure0 (\(ExitcodeT (Identity x)) -> x ^? _Left) +-- | A prism to exit success.+--+-- >>> preview _ExitSuccess (exitfailure0 99)+-- Nothing+-- >>> preview _ExitSuccess exitsuccess0+-- Just ()+-- >>> review _ExitSuccess "abc"+-- ExitcodeT (Identity (Right "abc")) _ExitSuccess :: Prism (Exitcode a)@@ -176,17 +270,29 @@ fmap f (ExitcodeT x) = ExitcodeT (fmap (fmap f) x) -instance Apply f => Apply (ExitcodeT f) where+instance Monad f => Apply (ExitcodeT f) where ExitcodeT f <.> ExitcodeT a =- ExitcodeT (liftF2 (<.>) f a)+ ExitcodeT (f >>= either (pure . Left) (\f' -> fmap (fmap f') a)) -instance Applicative f => Applicative (ExitcodeT f) where+instance Monad f => Applicative (ExitcodeT f) where pure = ExitcodeT . pure . pure ExitcodeT f <*> ExitcodeT a =- ExitcodeT (liftA2 (<*>) f a)+ ExitcodeT (f >>= either (pure . Left) (\f' -> fmap (fmap f') a)) -instance (Bind f, Monad f) => Bind (ExitcodeT f) where+-- |+--+-- >>> exitsuccess "abc" >>= \s -> exitsuccess (reverse s) :: ExitcodeT Identity String+-- ExitcodeT (Identity (Right "cba"))+-- >>> exitsuccess "abc" >>= \_ -> exitfailure0 99 :: ExitcodeT Identity ()+-- ExitcodeT (Identity (Left 99))+-- >>> exitfailure0 99 >>= \_ -> exitsuccess "abc" :: ExitcodeT Identity String+-- ExitcodeT (Identity (Left 99))+-- >>> exitfailure0 99 >>= \_ -> exitfailure0 88 :: ExitcodeT Identity ()+-- ExitcodeT (Identity (Left 99))+-- >>> let loop = loop in exitfailure0 99 >>= loop :: ExitcodeT Identity ()+-- ExitcodeT (Identity (Left 99))+instance Monad f => Bind (ExitcodeT f) where (>>-) = (>>=) @@ -195,7 +301,7 @@ ExitcodeT . return . return ExitcodeT x >>= f = ExitcodeT- (x >>= either (pure . Left) (\a -> let ExitcodeT y = f a in y))+ (x >>= either (pure . Left) (runExitcode . f)) instance Monad f => Alt (ExitcodeT f) where ExitcodeT a <!> ExitcodeT b =@@ -205,60 +311,57 @@ ExitcodeT a <> ExitcodeT b = ExitcodeT (a >>= either (const b) (pure a)) -instance Applicative f => Extend (ExitcodeT f) where+-- |+--+-- >>> duplicated (exitfailure0 99) :: ExitcodeT Identity (ExitcodeT Identity ())+-- ExitcodeT (Identity (Right (ExitcodeT (Identity (Left 99)))))+-- >>> duplicated (exitsuccess "abc") :: ExitcodeT Identity (ExitcodeT Identity String)+-- ExitcodeT (Identity (Right (ExitcodeT (Identity (Right "abc")))))+instance Extend f => Extend (ExitcodeT f) where duplicated (ExitcodeT x) =- ExitcodeT ((pure <$>) <$> x )+ ExitcodeT (extended (Right . ExitcodeT) x) instance (Eq1 f, Eq a) => Eq (ExitcodeT f a) where ExitcodeT a == ExitcodeT b = a `eq1` b instance Eq1 f => Eq1 (ExitcodeT f) where-# if MIN_VERSION_transformers(0,5,0) liftEq f (ExitcodeT a) (ExitcodeT b) = liftEq (liftEq f) a b-# else- eq1 (ExitcodeT a) (ExitcodeT b) =- eq1 a b-# endif instance (Ord1 f, Ord a) => Ord (ExitcodeT f a) where ExitcodeT a `compare` ExitcodeT b = a `compare1` b instance (Ord1 f) => Ord1 (ExitcodeT f) where-# if MIN_VERSION_transformers(0,5,0) liftCompare f (ExitcodeT a) (ExitcodeT b) = liftCompare (liftCompare f) a b-# else- compare1 (ExitcodeT a) (ExitcodeT b) =- compare1 a b-# endif instance (Show1 f, Show a) => Show (ExitcodeT f a) where showsPrec d (ExitcodeT m) =-# if MIN_VERSION_transformers(0,5,0) showsUnaryWith showsPrec1 "ExitcodeT" d m-# else- showsUnary1 "ExitcodeT" d m-# endif instance Show1 f => Show1 (ExitcodeT f) where-# if MIN_VERSION_transformers(0,5,0) liftShowsPrec sp sl d (ExitcodeT fa) = let showsPrecF = liftA2 liftShowsPrec (uncurry liftShowsPrec) (uncurry liftShowList) (sp, sl)- in showsUnaryWith showsPrecF "ExitcodeT" d fa-# else- showsPrec1 d (ExitcodeT fa) =- showsUnary1 "ExitcodeT" d fa-# endif+ in showsUnaryWith showsPrecF "ExitcodeT" d fa instance Foldable f => Foldable (ExitcodeT f) where foldr f z (ExitcodeT x) = foldr (flip (foldr f)) z x -instance Foldable1 f => Foldable1 (ExitcodeT f)-+-- |+--+-- >>> traverse id [exitfailure0 99] :: ExitcodeT Identity [()]+-- ExitcodeT (Identity (Left 99))+-- >>> traverse id [exitfailure0 99, exitsuccess0] :: ExitcodeT Identity [()]+-- ExitcodeT (Identity (Left 99))+-- >>> traverse id [exitfailure0 99, exitsuccess0, exitfailure0 88] :: ExitcodeT Identity [()]+-- ExitcodeT (Identity (Left 99))+-- >>> traverse id [exitsuccess0, exitfailure0 88] :: ExitcodeT Identity [()]+-- ExitcodeT (Identity (Left 88))+-- >>> traverse id [exitsuccess0] :: ExitcodeT Identity [()]+-- ExitcodeT (Identity (Right [()])) instance Traversable f => Traversable (ExitcodeT f) where traverse f (ExitcodeT x) = ExitcodeT <$> traverse (traverse f) x@@ -268,30 +371,64 @@ ExitcodeT (Right <$> liftIO io) instance MonadTrans ExitcodeT where- lift = ExitcodeT . (>>= pure . pure)+ lift =+ ExitcodeT . (>>= pure . pure) instance MonadReader r f => MonadReader r (ExitcodeT f) where- ask = lift ask- local f (ExitcodeT m) = ExitcodeT $ local f m+ ask =+ lift ask+ local f (ExitcodeT m) =+ ExitcodeT (local f m) +-- |+--+-- >>> writer'' ('x', "abc")+-- ExitcodeT ("abc",Right 'x')+-- >>> listen (exitfailure0 99 :: ExitcodeT ((,) String) ())+-- ExitcodeT ("",Left 99)+-- >>> listen (exitsuccess 99 :: ExitcodeT ((,) String) Int)+-- ExitcodeT ("",Right (99,""))+-- >>> tell "abc" :: ExitcodeT ((,) String) ()+-- ExitcodeT ("abc",Right ())+-- >>> pass (exitsuccess ('x', reverse)) :: ExitcodeT ((,) String) Char+-- ExitcodeT ("",Right 'x')+-- >>> pass (('x', reverse) <$ (exitfailure0 99 :: ExitcodeT ((,) String) ()))+-- ExitcodeT ("",Left 99) instance MonadWriter w f => MonadWriter w (ExitcodeT f) where- writer t = ExitcodeT . fmap pure $ writer t+ writer t =+ ExitcodeT . fmap pure $ writer t listen (ExitcodeT m) =- ExitcodeT ((\(e, w) -> (,w) <$> e) <$> listen m)- tell = ExitcodeT . fmap Right . tell- pass e = do- ((a, f), w) <- listen e- tell (f w)- pure a+ ExitcodeT ((\(e, w) -> (,w) <$> e) <$> listen m)+ tell =+ ExitcodeT . fmap Right . tell+ pass e =+ do ((a, f), w) <- listen e+ tell (f w)+ pure a instance MonadState s f => MonadState s (ExitcodeT f) where- get = ExitcodeT (fmap Right get)- put = ExitcodeT . fmap Right . put+ get =+ ExitcodeT (fmap Right get)+ put =+ ExitcodeT . fmap Right . put +-- |+--+-- >>> throwError 99 :: ExitcodeT (Either Int) String+-- ExitcodeT (Left 99)+-- >>> catchError exitsuccess0 exitfailure0 :: ExitcodeT (Either Int) ()+-- ExitcodeT (Right (Right ()))+-- >>> catchError (exitfailure0 99) (\_ -> exitsuccess0) :: ExitcodeT (Either Int) ()+-- ExitcodeT (Right (Left 99))+-- >>> catchError (exitfailure0 99) exitfailure0 :: ExitcodeT (Either Int) ()+-- ExitcodeT (Right (Left 99))+-- >>> catchError exitsuccess0 (\_ -> exitsuccess0) :: ExitcodeT (Either Int) ()+-- ExitcodeT (Right (Right ())) instance MonadError e f => MonadError e (ExitcodeT f) where- throwError = ExitcodeT . fmap Right . throwError+ throwError =+ ExitcodeT . fmap Right . throwError catchError (ExitcodeT f) h =- ExitcodeT $ flip catchError (runExitcode . h) f+ ExitcodeT (catchError f (runExitcode . h)) instance MonadRWS r w s f => MonadRWS r w s (ExitcodeT f) @@ -299,22 +436,22 @@ -- This code taken from the ExceptT instance: -- https://hackage.haskell.org/package/transformers-0.5.4.0/docs/src/Control.Monad.Trans.Except.html#line-237 instance MonadCont f => MonadCont (ExitcodeT f) where- callCC = liftCallCC callCC--liftCallCC :: Functor f => (((Either Int a -> f (Either Int b)) -> f (Either Int a)) -> f (Either Int a))- -> ((a -> ExitcodeT f b) -> ExitcodeT f a)- -> ExitcodeT f a-liftCallCC callCC' f =- ExitcodeT . callCC' $- \c -> runExitcode (f (\a -> ExitcodeT (c (Right a))))+ callCC =+ let liftCallCC callCC' f =+ ExitcodeT . callCC' $+ \c -> runExitcode (f (ExitcodeT . c . Right))+ in liftCallCC callCC +-- |+--+-- >>> hoist (\(Identity x) -> Just x) exitsuccess0+-- ExitcodeT (Just (Right ()))+-- >>> hoist (\(Identity x) -> Just x) (exitfailure0 99)+-- ExitcodeT (Just (Left 99)) instance MFunctor ExitcodeT where hoist nat (ExitcodeT x) = ExitcodeT (nat x) instance MMonad ExitcodeT where- embed nat (ExitcodeT x) = - let ex (Left e) = Left e- ex (Right (Left e)) = Left e- ex (Right (Right a)) = Right a- in ExitcodeT (fmap ex (let ExitcodeT y = nat x in y))+ embed nat (ExitcodeT x) =+ ExitcodeT (join <$> runExitcode (nat x))
test/Tests.hs view
@@ -25,13 +25,13 @@ newtype EW f a = EW { unEW :: ExitcodeT f a } deriving (Eq, Show) -instance (Applicative f, Arbitrary a) => Arbitrary (EW f a) where+instance (Monad f, Arbitrary a) => Arbitrary (EW f a) where arbitrary = fmap (EW . pure) TQC.arbitrary instance Functor f => Functor (EW f) where fmap f = EW . fmap f . unEW -instance Applicative f => Applicative (EW f) where+instance Monad f => Applicative (EW f) where pure = EW . pure EW f <*> EW a = EW (f <*> a)