packages feed

extensible-effects 1.2.0 → 1.2.1

raw patch · 9 files changed

+126/−10 lines, 9 files

Files

extensible-effects.cabal view
@@ -1,5 +1,5 @@ Name:                extensible-effects-Version:             1.2.0+Version:             1.2.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)@@ -8,7 +8,7 @@                      <http://okmij.org/ftp/Haskell/extensible/exteff.pdf>.                       Any help is appreciated!-Category:            Control+Category:            Control, Effect Author:              Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa Stability:           Experimental Homepage:            https://github.com/RobotGymnast/extensible-effects@@ -21,11 +21,13 @@ library     hs-source-dirs:    src/     ghc-options:       -Wall+    extensions:        Trustworthy     exposed-modules:   Control.Eff                        Control.Eff.Choose                        Control.Eff.Coroutine                        Control.Eff.Cut                        Control.Eff.Exception+                       Control.Eff.Fail                        Control.Eff.Fresh                        Control.Eff.Lift                        Control.Eff.Reader.Lazy
src/Control/Eff.hs view
@@ -77,6 +77,7 @@                   , run                   , interpose                   , handleRelay+                  , unsafeReUnion                   ) where  import Control.Applicative (Applicative (..), (<$>))@@ -88,18 +89,22 @@ -- The result is that a `VE` can produce an arbitrarily long chain of @`Union` r@ -- effects, terminated with a pure value. data VE w r = Val w | E !(Union r (VE w r))+  deriving Typeable  fromVal :: VE w r -> w fromVal (Val w) = w-fromVal _ = error "fromVal E"+fromVal _ = error "extensible-effects: fromVal was called on a non-terminal effect."+{-# INLINE fromVal #-}  -- | Basic datatype returned by all computations with extensible effects. -- The type @r@ is the type of effects that can be handled, -- and @a@ is the type of value that is returned. newtype Eff r a = Eff { runEff :: forall w. (a -> VE w r) -> VE w r }+  deriving Typeable  instance Functor (Eff r) where     fmap f m = Eff $ \k -> runEff m (k . f)+    {-# INLINE fmap #-}  instance Applicative (Eff r) where     pure = return@@ -115,15 +120,19 @@ -- we produce an effectful computation. send :: (forall w. (a -> VE w r) -> Union r (VE w r)) -> Eff r a send f = Eff (E . f)+{-# INLINE send #-}  -- | Tell an effectful computation that you're ready to start running effects -- and return a value. admin :: Eff r w -> VE w r admin (Eff m) = m Val+{-# INLINE admin #-}  -- | Get the result from a pure computation. run :: Eff () w -> w run = fromVal . admin+{-# INLINE run #-}+ -- the other case is unreachable since () has no constructors -- Therefore, run is a total function if m Val terminates. @@ -137,6 +146,7 @@   where passOn u' = send (<$> u') >>= loop   -- perhaps more efficient:   -- passOn u' = send (\k -> fmap (\w -> runEff (loop w) k) u')+{-# INLINE handleRelay #-}  -- | Given a request, either handle it or relay it. Both the handler -- and the relay can produce the same type of request that was handled.@@ -146,3 +156,4 @@           -> (t v -> Eff r a)           -> Eff r a interpose u loop h = maybe (send (<$> u) >>= loop) h $ prj u+{-# INLINE interpose #-}
src/Control/Eff/Coroutine.hs view
@@ -24,13 +24,21 @@ yield x = send (inj . Yield x)  -- | Status of a thread: done or reporting the value of the type a--- (For simplicity, a co-routine reports a value but accepts unit)-data Y r a = Done | Y a (() -> Eff r (Y r a))+--   (For simplicity, a co-routine reports a value but accepts unit)+--+--   Type parameter @r@ is the effect we're yielding from.+--+--   Type parameter @a@ is the type that is yielded.+--+--   Type parameter @w@ is the type of the value returned from the+--   coroutine when it has completed.+data Y r a w = Y a (() -> Eff r (Y r a w))+             | Done w  -- | Launch a thread and report its status.-runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a)+runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a w) runC m = loop (admin m)   where-    loop (Val _) = return Done+    loop (Val x) = return (Done x)     loop (E u)   = handleRelay u loop $                     \(Yield x k) -> return (Y x (loop . k))
src/Control/Eff/Exception.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} -- | Exception-producing and exception-handling effects-module Control.Eff.Exception( Exc (..)+module Control.Eff.Exception( Exc(..)                             , throwExc                             , runExc                             , catchExc
+ src/Control/Eff/Fail.hs view
@@ -0,0 +1,56 @@+{-# 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/State/Lazy.hs view
@@ -10,6 +10,8 @@                              , put                              , modify                              , runState+                             , evalState+                             , execState                              ) where  import Data.Typeable@@ -42,3 +44,11 @@  loop s (E u)   = handleRelay u (loop s) $                        \(State t k) -> let s' = t s                                        in loop s' (k s')++-- | Run a State effect, discarding the final state.+evalState :: Typeable s => s -> Eff (State s :> r) w -> Eff r w+evalState s = fmap snd . runState s++-- | Run a State effect and return the final state.+execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s+execState s = fmap fst . runState s
src/Control/Eff/State/Strict.hs view
@@ -23,6 +23,8 @@                                , put                                , modify                                , runState+                               , evalState+                               , execState                                ) where  import Data.Typeable@@ -55,3 +57,11 @@  loop !s (E u)   = handleRelay u (loop s) $                        \(State t k) -> let s' = t s                                        in loop s' (k s')++-- | Run a State effect, discarding the final state.+evalState :: Typeable s => s -> Eff (State s :> r) w -> Eff r w+evalState s = fmap snd . runState s++-- | Run a State effect and return the final state.+execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s+execState s = fmap fst . runState s
src/Data/OpenUnion1.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -35,6 +36,7 @@  -- for the sake of gcast1 newtype Id a = Id { runId :: a }+  deriving Typeable  -- | Where @r@ is @t1 :> t2 ... :> tn@, @`Union` r v@ can be constructed with a -- value of type @ti v@.@@ -55,7 +57,8 @@ instance Member t r => Member t (t' :> r)  -- | `SetMember` is similar to `Member`, but it allows types to belong to a--- "set", by taking advantage of the @r set -> t@ fundep:+-- \"set\". For every set, only one member can be in @r@ at any given time.+-- This allows us to specify exclusivity and uniqueness among arbitrary effects: -- -- > -- Terminal effects (effects which must be run last) -- > data Terminal@@ -66,7 +69,7 @@ -- > -- > -- Only allow a single unique Lift effect, by making a "Lift" set. -- > instance Member (Lift m) r => SetMember Lift (Lift m) r-class  Member t r => SetMember set (t :: * -> *) r | r set -> t+class Member t r => SetMember set (t :: * -> *) r | r set -> t instance SetMember set t r => SetMember set t (t' :> r)  {-# INLINE inj #-}
test/Test.hs view
@@ -12,6 +12,7 @@ import Test.QuickCheck  import Control.Eff+import Control.Eff.Fail import Control.Eff.Lift import Control.Eff.Reader.Lazy as LazyR import Control.Eff.State.Lazy as LazyS@@ -132,6 +133,20 @@ testFirstWriterLaziness = let (Just m, ()) = run $ LazyW.runFirstWriter $ mapM_ LazyW.tell [(), undefined]                           in assertNoUndefined (m :: ()) +testFailure :: Assertion+testFailure =+  let go :: Eff (Fail :> StrictW.Writer Int :> ()) Int+         -> Int+      go = fst . run . StrictW.runWriter (+) 0 . ignoreFail+      ret = go $ do+        StrictW.tell (1 :: Int)+        StrictW.tell (2 :: Int)+        StrictW.tell (3 :: Int)+        die+        StrictW.tell (4 :: Int)+        return 5+   in assertEqual "Fail should stop writing" 6 ret+ tests =   [ testProperty "Documentation example." testDocs   , testCase "Test runReader laziness." testReaderLaziness@@ -141,4 +156,5 @@   , testCase "Test runLastWriter laziness." testLastWriterLaziness   , testCase "Test runLastWriter strictness." testLastWriterStrictness   , testCase "Test runFirstWriter laziness." testFirstWriterLaziness+  , testCase "Test failure effect." testFailure   ]