extensible-effects 1.2.1 → 1.4.1
raw patch · 7 files changed
+129/−70 lines, 7 filesdep +transformersdep +transformers-basedep ~base
Dependencies added: transformers, transformers-base
Dependency ranges changed: base
Files
- extensible-effects.cabal +7/−4
- src/Control/Eff.hs +10/−4
- src/Control/Eff/Exception.hs +72/−1
- src/Control/Eff/Fail.hs +0/−56
- src/Control/Eff/Lift.hs +24/−2
- src/Data/OpenUnion1.hs +7/−1
- test/Test.hs +9/−2
extensible-effects.cabal view
@@ -1,5 +1,5 @@ Name: extensible-effects-Version: 1.2.1+Version: 1.4.1 Synopsis: An Alternative to Monad Transformers Description: This package introduces datatypes for typeclass-constrained effects, as an alternative to monad-transformer based (datatype-constrained)@@ -27,7 +27,6 @@ Control.Eff.Coroutine Control.Eff.Cut Control.Eff.Exception- Control.Eff.Fail Control.Eff.Fresh Control.Eff.Lift Control.Eff.Reader.Lazy@@ -40,7 +39,11 @@ other-modules: Data.OpenUnion1 build-depends: - base == 4.*+ base >= 4.6 && < 5+ -- For MonadIO instance+ , transformers == 0.3.0.*+ -- For MonadBase instance+ , transformers-base == 0.4.1.* test-suite extensible-effects-tests type: exitcode-stdio-1.0@@ -50,7 +53,7 @@ ghc-options: -rtsopts=all -threaded build-depends:- base == 4.*,+ base >= 4.6 && < 5, QuickCheck == 2.*, HUnit == 1.2.*, test-framework == 0.8.*,
src/Control/Eff.hs view
@@ -11,10 +11,11 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-} --- | Original work available at <http://okmij.org/ftp/Hgetell/extensible/Eff.hs>.+-- | Original work available at <http://okmij.org/ftp/Haskell/extensible/Eff.hs>. -- This module implements extensible effects as an alternative to monad transformers,--- as described in <http://okmij.org/ftp/Hgetell/extensible/exteff.pdf>.+-- as described in <http://okmij.org/ftp/Haskell/extensible/exteff.pdf>. -- -- Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype. -- A contrived example is:@@ -85,6 +86,10 @@ import Data.OpenUnion1 import Data.Typeable +#if MIN_VERSION_base(4,7,0)+#define Typeable1 Typeable+#endif+ -- | A `VE` is either a value, or an effect of type @`Union` r@ producing another `VE`. -- The result is that a `VE` can produce an arbitrarily long chain of @`Union` r@ -- effects, terminated with a pure value.@@ -111,10 +116,11 @@ (<*>) = ap instance Monad (Eff r) where+ return x = Eff $ \k -> k x {-# INLINE return #-}++ m >>= f = Eff $ \k -> runEff m (\v -> runEff (f v) k) {-# INLINE (>>=) #-}- return x = Eff $ \k -> k x- m >>= f = Eff $ \k -> runEff m (\v -> runEff (f v) k) -- | Given a method of turning requests into results, -- we produce an effectful computation.
src/Control/Eff/Exception.hs view
@@ -2,32 +2,62 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} -- | Exception-producing and exception-handling effects module Control.Eff.Exception( Exc(..)+ , Fail , throwExc+ , die , runExc+ , runFail , catchExc+ , onFail+ , rethrowExc+ , liftEither+ , liftEitherM+ , liftMaybe+ , ignoreFail ) where +import Control.Monad (void) import Data.Typeable import Control.Eff+import Control.Eff.Lift +#if MIN_VERSION_base(4,7,0)+#define Typeable1 Typeable+#endif+ -- | These are exceptions of the type e. This is akin to the error monad. newtype Exc e v = Exc e deriving (Functor, Typeable) +type Fail = Exc ()+ -- | Throw an exception in an effectful computation. throwExc :: (Typeable e, Member (Exc e) r) => e -> Eff r a throwExc e = send (\_ -> inj $ Exc e)+{-# INLINE throwExc #-} +-- | Makes an effect fail, preventing future effects from happening.+die :: Member Fail r => Eff r a+die = throwExc ()+{-# INLINE die #-}+ -- | Run a computation that might produce an exception. runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a)-runExc m = loop (admin m)+runExc = loop . admin where loop (Val x) = return (Right x) loop (E u) = handleRelay u loop (\(Exc e) -> return (Left e)) +-- | Runs a failable effect, such that failed computation return 'Nothing', and+-- 'Just' the return value on success.+runFail :: Eff (Fail :> r) a -> Eff r (Maybe a)+runFail = fmap (either (\_-> Nothing) Just) . runExc+{-# INLINE runFail #-}+ -- | Run a computation that might produce exceptions, -- and give it a way to deal with the exceptions that come up. catchExc :: (Typeable e, Member (Exc e) r)@@ -38,3 +68,44 @@ where loop (Val x) = return x loop (E u) = interpose u loop (\(Exc e) -> handle e)++-- | Add a default value (i.e. failure handler) to a fallible computation.+-- This hides the fact that a failure happened.+onFail :: Eff (Fail :> r) a -- ^ The fallible computation.+ -> Eff r a -- ^ The computation to run on failure.+ -> Eff r a+onFail e handle = runFail e >>= maybe handle return+{-# INLINE onFail #-}++-- | Run a computation until it produces an exception,+-- and convert and throw that exception in a new context.+rethrowExc :: (Typeable e, Typeable e', Member (Exc e') r)+ => (e -> e')+ -> Eff (Exc e :> r) a+ -> Eff r a+rethrowExc t eff = runExc eff >>= either (throwExc . t) return++-- | Treat Lefts as exceptions and Rights as return values.+liftEither :: (Typeable e, Member (Exc e) r) => Either e a -> Eff r a+liftEither (Left e) = throwExc e+liftEither (Right a) = return a+{-# INLINE liftEither #-}++-- | `liftEither` in a lifted Monad+liftEitherM :: (Typeable1 m, Typeable e, Member (Exc e) r, SetMember Lift (Lift m) r)+ => m (Either e a)+ -> Eff r a+liftEitherM m = lift m >>= liftEither+{-# INLINE liftEitherM #-}++-- | Lift a maybe into the 'Fail' effect, causing failure if it's 'Nothing'.+liftMaybe :: Member Fail r => Maybe a -> Eff r a+liftMaybe = maybe die return+{-# INLINE liftMaybe #-}++-- | Ignores a failure event. Since the event can fail, you cannot inspect its+-- return type, because it has none on failure. To inspect it, use 'runFail'.+ignoreFail :: Eff (Fail :> r) a+ -> Eff r ()+ignoreFail e = void e `onFail` return ()+{-# INLINE ignoreFail #-}
− src/Control/Eff/Fail.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}--- | Effects which fail.-module Control.Eff.Fail( Fail- , die- , runFail- , ignoreFail- , onFail- ) where--import Data.Typeable-import Control.Eff-import Control.Monad---- | 'Fail' represents effects which can fail. This is akin to the Maybe monad.-data Fail v = Fail- deriving (Functor, Typeable)---- | Makes an effect fail, preventing future effects from happening.-die :: Member Fail r- => Eff r ()-die = send (const (inj Fail))-{-# INLINE die #-}---- | Runs a failable effect, such that failed computation return 'Nothing', and--- 'Just' the return value on success.-runFail :: Eff (Fail :> r) a- -> Eff r (Maybe a)-runFail m = loop (admin m)- where- loop (Val x) = return (Just x)- loop (E u) = handleRelay u loop (const (return Nothing))-{-# INLINE runFail #-}---- | Given a computation to run on failure, and a computation that can fail,--- this function runs the computation that can fail, and if it fails, gets--- the return value from the other computation. This hides the fact that a--- failure even happened, and returns a default value for when it does.-onFail :: Eff r a -- ^ The computation to run on failure.- -> Eff (Fail :> r) a -- ^ The computation which can fail.- -> Eff r a-onFail sideshow mainEvent = do- r <- runFail mainEvent- case r of- Nothing -> sideshow- Just y -> return y-{-# INLINE onFail #-}---- | Ignores a failure event. Since the event can fail, you cannot inspect its--- return type, because it has none on failure. To inspect it, use 'runFail'.-ignoreFail :: Eff (Fail :> r) a- -> Eff r ()-ignoreFail = onFail (return ()) . void-{-# INLINE ignoreFail #-}
src/Control/Eff/Lift.hs view
@@ -5,6 +5,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS -fno-warn-orphans #-} -- | Lifting primitive Monad types to effectful computations. -- We only allow a single Lifted Monad because Monads aren't commutative -- (e.g. Maybe (IO a) is functionally distinct from IO (Maybe a)).@@ -14,22 +17,41 @@ ) where import Control.Eff+import Control.Monad.Base+import Control.Monad.IO.Class (MonadIO (..)) import Data.Typeable +#if MIN_VERSION_base(4,7,0)+#define Typeable1 Typeable+#endif+ -- | Lift a Monad m to an effect. data Lift m v = forall a. Lift (m a) (a -> v)+#if MIN_VERSION_base(4,7,0)+ deriving (Typeable) -- starting from ghc-7.8 Typeable can only be derived+#else instance Typeable1 m => Typeable1 (Lift m) where typeOf1 _ = mkTyConApp (mkTyCon3 "" "Eff" "Lift") [typeOf1 (undefined :: m ())]+#endif +instance SetMember Lift (Lift m) (Lift m :> ())+ instance Functor (Lift m) where fmap f (Lift m k) = Lift m (f . k)+ {-# INLINE fmap #-} -instance SetMember Lift (Lift m) (Lift m :> ())+instance (Typeable1 m, MonadIO m, SetMember Lift (Lift m) r) => MonadIO (Eff r) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-} +instance (MonadBase b m, Typeable1 m, SetMember Lift (Lift m) r) => MonadBase b (Eff r) where+ liftBase = lift . liftBase+ {-# INLINE liftBase #-}+ -- | Lift a Monad to an Effect.-lift :: (Typeable1 m, Member (Lift m) r, SetMember Lift (Lift m) r) => m a -> Eff r a+lift :: (Typeable1 m, SetMember Lift (Lift m) r) => m a -> Eff r a lift m = send (inj . Lift m) -- | The handler of Lift requests. It is meant to be terminal:
src/Data/OpenUnion1.hs view
@@ -8,7 +8,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,7,0)+#define Typeable1 Typeable+#endif -- | Original work at <http://okmij.org/ftp/Haskell/extensible/OpenUnion1.hs>. -- Open unions (type-indexed co-products) for extensible effects. -- This implementation relies on _closed_ overlapping instances@@ -51,7 +55,9 @@ infixr 1 :> data ((a :: * -> *) :> b) --- | The @`Member` t r@ determines whether @t@ is anywhere in the sum type @r@.+-- | The @`Member` t r@ specifies whether @t@ is present anywhere in the sum+-- type @r@, where @t@ is some effectful type,+-- e.g. @`Lift` `IO`@, @`State` Int`@. class Member t r instance Member t (t :> r) instance Member t r => Member t (t' :> r)
test/Test.hs view
@@ -12,7 +12,7 @@ import Test.QuickCheck import Control.Eff-import Control.Eff.Fail+import Control.Eff.Exception import Control.Eff.Lift import Control.Eff.Reader.Lazy as LazyR import Control.Eff.State.Lazy as LazyS@@ -135,7 +135,7 @@ testFailure :: Assertion testFailure =- let go :: Eff (Fail :> StrictW.Writer Int :> ()) Int+ let go :: Eff (Exc () :> StrictW.Writer Int :> ()) Int -> Int go = fst . run . StrictW.runWriter (+) 0 . ignoreFail ret = go $ do@@ -146,6 +146,13 @@ StrictW.tell (4 :: Int) return 5 in assertEqual "Fail should stop writing" 6 ret++-- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved.+testLift :: Assertion+testLift = runLift possiblyAmbiguous+ where+ possiblyAmbiguous :: (Typeable1 m, Monad m, SetMember Lift (Lift m) r) => Eff r ()+ possiblyAmbiguous = lift $ return () tests = [ testProperty "Documentation example." testDocs