diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/exitcode.cabal b/exitcode.cabal --- a/exitcode.cabal +++ b/exitcode.cabal @@ -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: - <> +description: + <> . Monad transformer for exit codes license: BSD3 license-file: LICENCE author: Queensland Functional Programming Lab -maintainer: Queensland Functional Programming Lab -copyright: Copyright (C) 2017,2018 Commonwealth Scientific and Industrial Research Organisation (CSIRO) +maintainer: Tony Morris +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 diff --git a/src/Control/Exitcode.hs b/src/Control/Exitcode.hs --- a/src/Control/Exitcode.hs +++ b/src/Control/Exitcode.hs @@ -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)) diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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)