packages feed

extensible-effects 1.0 → 1.1.0

raw patch · 12 files changed

+611/−366 lines, 12 filesdep +QuickCheckdep +extensible-effectsdep +test-frameworkdep ~base

Dependencies added: QuickCheck, extensible-effects, test-framework, test-framework-quickcheck2

Dependency ranges changed: base

Files

extensible-effects.cabal view
@@ -1,9 +1,18 @@ Name:                extensible-effects-Version:             1.0-Description:         Extensible Effects: An Alternative to Monad Transformers (http://okmij.org/ftp/Haskell/extensible/exteff.pdf)+Version:             1.1.0+Synopsis:            An Alternative to Monad Transformers+Description:         This package introduces datatypes for typeclass-constrained effects,+                     as an alternative to monad-transformer based (datatype-constrained)+                     approach of multi-layered effects.+                     For more information, see the original paper at+                     <http://okmij.org/ftp/Haskell/extensible/exteff.pdf>. Category:            Control+Author:              Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa+Stability:           Experimental+Homepage:            https://github.com/RobotGymnast/extensible-effects Maintainer:          benjamin.foppa@gmail.com License:             MIT+Tested-With:         GHC==7.6.3 Build-Type:          Simple Cabal-Version:       >= 1.9.2 @@ -11,8 +20,33 @@     hs-source-dirs:    src/     ghc-options:       -Wall     exposed-modules:   Control.Eff-                       Data.OpenUnion1+                       Control.Eff.Choose+                       Control.Eff.Coroutine+                       Control.Eff.Cut+                       Control.Eff.Exception+                       Control.Eff.Fresh+                       Control.Eff.Lift+                       Control.Eff.State+                       Control.Eff.Trace+    other-modules:     Data.OpenUnion1      build-depends: -                    base >= 4,-                    base < 5+                    base == 4.*++test-suite extensible-effects-tests+  type: exitcode-stdio-1.0+  main-is: Test.hs+  hs-source-dirs: test/++  ghc-options: -rtsopts=all -threaded++  build-depends:+    base == 4.*,+    QuickCheck == 2.*,+    test-framework == 0.8.*,+    test-framework-quickcheck2 == 0.3.*,+    extensible-effects++source-repository head+  type: git+  location: https://github.com/RobotGymnast/extensible-effects
src/Control/Eff.hs view
@@ -12,66 +12,79 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} --- | Original work available at: http://okmij.org/ftp/Hgetell/extensible/Eff.hs.+-- | Original work available at <http://okmij.org/ftp/Hgetell/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/Hgetell/extensible/exteff.pdf>. -- -- Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype. -- A contrived example is: -----   -- Print a list of numbers, then print their sum.---   printAndSum :: (Member (Lift IO) e, Member State e) => [Integer] -> Eff e Integer---   printAndSum (x:xs) = do---        lift $ putStrLn $ show x---        onState (+ x)---   printAndSum [] = getState >>= lift . putStrLn-module Control.Eff( Eff+-- > {-# LANGUAGE FlexibleContexts #-}+-- > import Control.Eff+-- > import Control.Eff.Lift+-- > import Control.Eff.State+-- > import Control.Monad (void)+-- > import Data.Typeable+-- >+-- > -- Write the elements of a list of numbers, in order.+-- > writeAll :: (Typeable a, Member (Writer a) e)+-- >          => [a]+-- >          -> Eff e ()+-- > writeAll = mapM_ putWriter+-- >+-- > -- Add a list of numbers to the current state.+-- > sumAll :: (Typeable a, Num a, Member (State a) e)+-- >        => [a]+-- >        -> Eff e ()+-- > sumAll = mapM_ (onState . (+))+-- >+-- > -- Write a list of numbers and add them to the current state.+-- > writeAndAdd :: (Member (Writer Integer) e, Member (State Integer) e)+-- >             => [Integer]+-- >             -> Eff e ()+-- > writeAndAdd l = do+-- >     writeAll l+-- >     sumAll l+-- >+-- > -- Sum a list of numbers.+-- > sumEff :: (Num a, Typeable a) => [a] -> a+-- > sumEff l = let (s, ()) = run $ runState 0 $ sumAll l+-- >            in s+-- >+-- > -- Safely get the last element of a list.+-- > -- Nothing for empty lists; Just the last element otherwise.+-- > lastEff :: Typeable a => [a] -> Maybe a+-- > lastEff l = let (a, ()) = run $ runWriter $ writeAll l+-- >             in a+-- >+-- > -- Get the last element and sum of a list+-- > lastAndSum :: (Typeable a, Num a) => [a] -> (Maybe a, a)+-- > lastAndSum l = let (lst, (total, ())) = run $ runWriter $ runState 0 $ writeAndAdd l+-- >                in (lst, total)+module Control.Eff(+                    Eff+                  , VE (..)                   , Member+                  , Union                   , (:>)-                  , run+                  , inj+                  , prj+                  , prjForce+                  , decomp                   , send                   , admin-                  , Reader-                  , runReader-                  , getReader-                  , local-                  , Trace-                  , trace-                  , runTrace-                  , Yield-                  , yield-                  , runC-                  , Y (..)-                  , State-                  , getState-                  , putState-                  , onState-                  , runState-                  , Choose-                  , choose-                  , runChoice-                  , Lift-                  , lift-                  , runLift-                  , Exc-                  , throwError-                  , runError-                  , catchError-                  , Fresh-                  , fresh-                  , runFresh-                  , CutFalse-                  , call-                  , cutfalse+                  , run+                  , interpose+                  , handleRelay                   ) where  import Control.Applicative (Applicative (..), (<$>))-import Control.Monad (join, ap)+import Control.Monad (ap) import Data.OpenUnion1 import Data.Typeable --- | 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`+-- | 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. data VE w r = Val w | E !(Union r (VE w r)) @@ -79,12 +92,10 @@ fromVal (Val w) = w fromVal _ = error "fromVal E" --- | A `Request w r a` consumes values of type `a`, and produces `VE w r`,--- i.e. a `w` value embedded arbitrarily deep in `Union r` effects.-type Request w r a = a -> VE w r---- Eff r a can consume a request (i.e. a -> VE w r)-newtype Eff r a = Eff { runEff :: forall w. Request w r a -> VE w r }+-- | 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 }  instance Functor (Eff r) where     fmap f m = Eff $ \k -> runEff m (k . f)@@ -99,316 +110,38 @@     return x = Eff $ \k -> k x     m >>= f  = Eff $ \k -> runEff m (\v -> runEff (f v) k) --- send a request and wait for a reply+-- | Given a method of turning requests into results,+-- 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) --- administer a client: launch a coroutine and wait for it--- to send a request or terminate with a value+-- | 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 --- --------------------------------------------------------------------------- The initial case, no effects--data Void -- no constructors---- The type of run ensures that all effects must be handled:--- only pure computations may be run.-run :: Eff Void w -> w+-- | Get the result from a pure computation.+run :: Eff () w -> w run = fromVal . admin--- the other case is unreachable since Void has no constructors+-- the other case is unreachable since () has no constructors -- Therefore, run is a total function if m Val terminates. --- A convenient pattern: given a request (open union), either--- handle it or relay it.-handleRelay :: Typeable1 t =>-     Union (t :> r) v -> (v -> Eff r a) -> (t v -> Eff r a) -> Eff r a+-- | Given a request, either handle it or relay it.+handleRelay :: Typeable1 t+            => Union (t :> r) v -- ^ Request+            -> (v -> Eff r a)   -- ^ Relay the request+            -> (t v -> Eff r a) -- ^ Handle the request of type t+            -> Eff r a handleRelay u loop h = either passOn h $ decomp u   where passOn u' = send (<$> u') >>= loop   -- perhaps more efficient:   -- passOn u' = send (\k -> fmap (\w -> runEff (loop w) k) u') --- Add something like Control.Exception.catches? It could be useful--- for control with cut.--interpose :: (Typeable1 t, Functor t, Member t r) =>-     Union r v -> (v -> Eff r a) -> (t v -> Eff r a) -> Eff r a+-- | 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.+interpose :: (Typeable1 t, Functor t, Member t r)+          => Union r v+          -> (v -> Eff r a)+          -> (t v -> Eff r a)+          -> Eff r a interpose u loop h = maybe (send (<$> u) >>= loop) h $ prj u---- --------------------------------------------------------------------------- The Reader monad---- | The request for a value of type e from the current environment.--- This environment is analogous to a parameter of type e.-newtype Reader e v = Reader (e -> v)-    deriving (Typeable, Functor)--getReader :: Typeable e => Member (Reader e) r => Eff r e-getReader = send (inj . Reader)---- | The handler of Reader requests. The return type shows that--- all Reader requests are fully handled.-runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w-runReader m e = loop (admin m) where- loop (Val x) = return x- loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e))---- | Locally rebind the value in the dynamic environment.--- This function both requests and admins Reader requests.-local :: (Typeable e, Member (Reader e) r) =>-     (e -> e) -> Eff r a -> Eff r a-local f m = do-  e <- f <$> getReader-  let loop (Val x) = return x-      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))-  loop (admin m)----- --------------------------------------------------------------------------- Exceptions---- exceptions of the type e; no resumption-newtype Exc e v = Exc e-    deriving (Functor, Typeable)---- The type is inferred-throwError :: (Typeable e, Member (Exc e) r) => e -> Eff r a-throwError e = send (\_ -> inj $ Exc e)--runError :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a)-runError m = loop (admin m)- where- loop (Val x)  = return (Right x)- loop (E u)    = handleRelay u loop (\(Exc e) -> return (Left e))---- The handler is allowed to rethrow the exception-catchError :: (Typeable e, Member (Exc e) r) =>-        Eff r a -> (e -> Eff r a) -> Eff r a-catchError m handle = loop (admin m)- where- loop (Val x)  = return x- loop (E u)    = interpose u loop (\(Exc e) -> handle e)----- --------------------------------------------------------------------------- Non-determinism (choice)---- choose lst non-deterministically chooses one value from the lst--- choose [] thus corresponds to failure-data Choose v = forall a. Choose [a] (a -> v)-              deriving (Typeable)--instance Functor Choose where-    fmap f (Choose lst k) = Choose lst (f . k)--choose :: Member Choose r => [a] -> Eff r a-choose lst = send (inj . Choose lst)---- MonadPlus-like operators are expressible via choose--mzero' :: Member Choose r => Eff r a-mzero' = choose []--mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a-mplus' m1 m2 = join $ choose [m1,m2]----- The interpreter-runChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a]-runChoice m = loop (admin m)- where- loop (Val x)  = return [x]- loop (E u)    = handleRelay u loop (\(Choose lst k) -> handle lst k)- -- Need the signature since local bindings aren't polymorphic any more- handle :: [t] -> (t -> VE a (Choose :> r)) -> Eff r [a]- handle [] _  = return []- handle [x] k = loop (k x)- handle lst k = concat <$> mapM (loop . k) lst----- --------------------------------------------------------------------------- | Strict state.--- Example:--- Implementing Fresh in terms of State but not revealing that fact.--- runFresh' :: (Typeable i, Enum i, Num i) => Eff (Fresh i :> r) w -> i -> Eff r w--- runFresh' m s = fst <$> runState s (loop $ admin m)---  where---   loop (Val x) = return x---   loop (E u)   = case decomp u of---     Right (Fresh k) -> do---                       n <- getState---                       putState (n + 1)---                       loop (k n)---     Left u' -> send (\k -> unsafeReUnion $ k <$> u') >>= loop-data State s w = State (s -> s) (s -> w)-  deriving (Typeable, Functor)--putState :: Typeable e => Member (State e) r => e -> Eff r ()-putState = onState . const--getState :: Typeable e => Member (State e) r => Eff r e-getState = send (inj . State id)--onState :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r ()-onState f = send (\k -> inj (State f (\_ -> k ())))--runState :: Typeable s => s -> Eff (State s :> r) w -> Eff r (w, s)-runState s0 = loop s0 . admin where- loop s (Val x) = return (x, s)- loop s (E u)   = handleRelay u (loop s) $-                       \(State t k) -> let s' = t s in s' `seq` loop s' (k s')--newtype Fresh i v = Fresh (i -> v)-    deriving (Functor, Typeable)--fresh :: (Typeable i, Enum i, Member (Fresh i) r) => Eff r i-fresh = send (inj . Fresh)--runFresh :: (Typeable i, Enum i) => Eff (Fresh i :> r) w -> i -> Eff r w-runFresh m s0 = loop s0 (admin m)-  where-    loop _ (Val x) = return x-    loop s (E u)   = handleRelay u (loop s) $-                          \(Fresh k) -> (loop $! succ s) (k s)----- --------------------------------------------------------------------------- Tracing (debug printing)--data Trace v = Trace String (() -> v)-    deriving (Typeable, Functor)---- Printing a string in a trace-trace :: Member Trace r => String -> Eff r ()-trace x = send (inj . Trace x)---- The handler for IO request: a terminal handler-runTrace :: Eff (Trace :> Void) w -> IO w-runTrace m = loop (admin m) where- loop (Val x) = return x- loop (E u)   = prjForce u $ \(Trace s k) -> putStrLn s >> loop (k ())---- --------------------------------------------------------------------------- Lifting: emulating monad transformers--data Lift m v = forall a. Lift (m a) (a -> v)---- For ST monad, we have to define LiftST since (ST s) can't be Typeable:--- s must be polymorphic without any constraints--{---ghci 7.6.3 ==>-Eff.hs:465:29: Warning:-    In the use of `mkTyCon' (imported from Data.Typeable):-    Deprecated: "either derive Typeable, or use mkTyCon3 instead"---}-instance Typeable1 m => Typeable1 (Lift m) where-    typeOf1 _ =-     mkTyConApp (mkTyCon3 "" "Eff" "Lift") [typeOf1 (undefined:: m ())]--instance Functor (Lift m) where-    fmap f (Lift m k) = Lift m (f . k)---- | Lift a Monad to an Effect.-lift :: (Typeable1 m, Member (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: we only allow--- a single Lifted Monad because Monads aren't commutative--- (e.g. Maybe (IO a) is functionally different from IO (Maybe a)).-runLift :: (Monad m, Typeable1 m) => Eff (Lift m :> Void) w -> m w-runLift m = loop (admin m) where- loop (Val x) = return x- loop (E u) = prjForce u $ \(Lift m' k) -> m' >>= loop . k---- --------------------------------------------------------------------------- Co-routines--- The interface is intentionally chosen to be the same as in transf.hs---- | The yield request: reporting the value of type e and suspending--- the coroutine--- (For simplicity, a co-routine reports a value but accepts unit)-data Yield a v = Yield a (() -> v)-    deriving (Typeable, Functor)--yield :: (Typeable a, Member (Yield a) r) => a -> Eff r ()-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))---- | Launch a thread and report its status.-runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a)-runC m = loop (admin m) where- loop (Val _) = return Done- loop (E u)   = handleRelay u loop $-                 \(Yield x k) -> return (Y x (loop . k))----- --------------------------------------------------------------------------- An example of non-trivial interaction of effects, handling of two--- effects together--- Non-determinism with control (cut)--- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper.--- Hinze suggests expressing cut in terms of cutfalse---  ! = return () `mplus` cutfalse--- where---  cutfalse :: m a--- satisfies the following laws---   cutfalse >>= k  = cutfalse              (F1)---   cutfalse | m    = cutfalse              (F2)--- (note: m `mplus` cutfalse is different from cutfalse `mplus` m)--- In other words, cutfalse is the left zero of both bind and mplus.------ Hinze also introduces the operation call :: m a -> m a that--- delimits the effect of cut: call m executes m. If the cut is--- invoked in m, it discards only the choices made since m was called.--- Hinze postulates the axioms of call:------   call false = false                          (C1)---   call (return a | m) = return a | call m     (C2)---   call (m | cutfalse) = call m                (C3)---   call (lift m >>= k) = lift m >>= (call . k) (C4)------ call m behaves like m except any cut inside m has only a local effect,--- he says.---- Hinze noted a problem with the `mechanical' derivation of backtracing--- monad transformer with cut: no axiom specifying the interaction of--- call with bind; no way to simplify nested invocations of call.---- We use exceptions for cutfalse--- Therefore, the law ``cutfalse >>= k       = cutfalse''--- is satisfied automatically since all exceptions have the above property.--data CutFalse = CutFalse deriving Typeable--cutfalse :: Member (Exc CutFalse) r => Eff r a-cutfalse = throwError CutFalse---- The interpreter -- it is like reify . reflect with a twist--- Compare this implementation with the huge implementation of call--- in Hinze 2000 (Figure 9)--- Each clause corresponds to the axiom of call or cutfalse.--- All axioms are covered.--- The code clearly expresses the intuition that call watches the choice points--- of its argument computation. When it encounteres a cutfalse request,--- it discards the remaining choicepoints.---- It completely handles CutFalse effects but not non-determinism-call :: Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a-call m = loop [] (admin m) where- loop jq (Val x) = return x `mplus'` next jq          -- (C2)- loop jq (E u) = case decomp u of-    Right (Exc CutFalse) -> mzero'  -- drop jq (F2)-    Left u' -> check jq u'-- check jq u | Just (Choose [] _) <- prj u  = next jq  -- (C1)- check jq u | Just (Choose [x] k) <- prj u = loop jq (k x)  -- (C3), optim- check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3)- check jq u = send (<$> u) >>= loop jq      -- (C4)-- next []    = mzero'- next (h:t) = loop t h
+ src/Control/Eff/Choose.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+-- | Nondeterministic choice effect+module Control.Eff.Choose( Choose (..)+                         , choose+                         , runChoice+                         , mzero'+                         , mplus'+                         ) where++import Control.Applicative ((<$>))+import Control.Monad (join)+import Data.Typeable++import Control.Eff++-- | Nondeterministic choice+data Choose v = forall a. Choose [a] (a -> v)+              deriving (Typeable)++instance Functor Choose where+    fmap f (Choose lst k) = Choose lst (f . k)++-- | choose lst non-deterministically chooses one value from the lst+-- choose [] thus corresponds to failure+choose :: Member Choose r => [a] -> Eff r a+choose lst = send (inj . Choose lst)++-- | MonadPlus-like operators are expressible via choose+mzero' :: Member Choose r => Eff r a+mzero' = choose []++-- | MonadPlus-like operators are expressible via choose+mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a+mplus' m1 m2 = join $ choose [m1,m2]++-- | Run a nondeterministic effect, returning all values.+runChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a]+runChoice m = loop (admin m)+ where+  loop (Val x)  = return [x]+  loop (E u)    = handleRelay u loop (\(Choose lst k) -> handle lst k)++  handle :: [t] -> (t -> VE a (Choose :> r)) -> Eff r [a]+  handle [] _  = return []+  handle [x] k = loop (k x)+  handle lst k = concat <$> mapM (loop . k) lst
+ src/Control/Eff/Coroutine.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Coroutines implemented with extensible effects+module Control.Eff.Coroutine( Yield+                            , yield+                            , runC+                            , Y (..)+                            ) where++import Data.Typeable++import Control.Eff++-- | The yield request: reporting a value of type e and suspending+-- the coroutine. For readability, a coroutine accepts a unit to produce+-- its value.+data Yield a v = Yield a (() -> v)+    deriving (Typeable, Functor)++-- | Yield a value of type a and suspend the coroutine.+yield :: (Typeable a, Member (Yield a) r) => a -> Eff r ()+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))++-- | Launch a thread and report its status.+runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a)+runC m = loop (admin m)+  where+    loop (Val _) = return Done+    loop (E u)   = handleRelay u loop $+                    \(Yield x k) -> return (Y x (loop . k))
+ src/Control/Eff/Cut.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+-- | An example of non-trivial interaction of effects, handling of two+-- effects together+-- Non-determinism with control (cut)+-- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper.+-- Hinze suggests expressing cut in terms of cutfalse:+--+-- > = return () `mplus` cutfalse+-- > where+-- >  cutfalse :: m a+--+-- satisfies the following laws:+--+-- >  cutfalse >>= k  = cutfalse              (F1)+-- >  cutfalse | m    = cutfalse              (F2)+--+-- (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@)+-- In other words, cutfalse is the left zero of both bind and mplus.+--+-- Hinze also introduces the operation @`call` :: m a -> m a@ that+-- delimits the effect of cut: @`call` m@ executes m. If the cut is+-- invoked in m, it discards only the choices made since m was called.+-- Hinze postulates the axioms of `call`:+--+-- >  call false = false                          (C1)+-- >  call (return a | m) = return a | call m     (C2)+-- >  call (m | cutfalse) = call m                (C3)+-- >  call (lift m >>= k) = lift m >>= (call . k) (C4)+--+-- @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect,+-- he says.+--+-- Hinze noted a problem with the \"mechanical\" derivation of backtracing+-- monad transformer with cut: no axiom specifying the interaction of+-- call with bind; no way to simplify nested invocations of call.+--+-- We use exceptions for cutfalse+-- Therefore, the law @cutfalse >>= k = cutfalse@+-- is satisfied automatically since all exceptions have the above property.+module Control.Eff.Cut( CutFalse+                      , call+                      , cutfalse+                      ) where++import Control.Applicative ((<$>))+import Data.Typeable++import Control.Eff+import Control.Eff.Choose+import Control.Eff.Exception++data CutFalse = CutFalse deriving Typeable++cutfalse :: Member (Exc CutFalse) r => Eff r a+cutfalse = throwExc CutFalse++-- | The interpreter -- it is like reify . reflect with a twist+-- Compare this implementation with the huge implementation of call+-- in Hinze 2000 (Figure 9)+-- Each clause corresponds to the axiom of call or cutfalse.+-- All axioms are covered.+-- The code clearly expresses the intuition that call watches the choice points+-- of its argument computation. When it encounteres a cutfalse request,+-- it discards the remaining choicepoints.+-- It completely handles CutFalse effects but not non-determinism.+call :: Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a+call m = loop [] (admin m) where+ loop jq (Val x) = return x `mplus'` next jq          -- (C2)+ loop jq (E u) = case decomp u of+    Right (Exc CutFalse) -> mzero'  -- drop jq (F2)+    Left u' -> check jq u'++ check jq u | Just (Choose [] _) <- prj u  = next jq  -- (C1)+ check jq u | Just (Choose [x] k) <- prj u = loop jq (k x)  -- (C3), optim+ check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3)+ check jq u = send (<$> u) >>= loop jq      -- (C4)++ next []    = mzero'+ next (h:t) = loop t h
+ src/Control/Eff/Exception.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Exception-producing and exception-handling effects+module Control.Eff.Exception( Exc (..)+                            , throwExc+                            , runExc+                            , catchExc+                            ) where++import Data.Typeable++import Control.Eff++-- | These are exceptions of the type e. This is akin to the error monad.+newtype Exc e v = Exc e+    deriving (Functor, Typeable)++-- | Throw an exception in an effectful computation.+throwExc :: (Typeable e, Member (Exc e) r) => e -> Eff r a+throwExc e = send (\_ -> inj $ Exc e)++-- | 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)+ where+  loop (Val x)  = return (Right x)+  loop (E u)    = handleRelay u loop (\(Exc e) -> return (Left e))++-- | 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)+         => Eff r a+         -> (e -> Eff r a)+         -> Eff r a+catchExc m handle = loop (admin m)+ where+  loop (Val x)  = return x+  loop (E u)    = interpose u loop (\(Exc e) -> handle e)
+ src/Control/Eff/Fresh.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Create unique Enumerable values.+module Control.Eff.Fresh( Fresh+                        , fresh+                        , runFresh+                        ) where++import Data.Typeable++import Control.Eff++-- | Create unique Enumerable values.+newtype Fresh i v = Fresh (i -> v)+    deriving (Functor, Typeable)++-- | Produce a value that has not been previously produced.+fresh :: (Typeable i, Enum i, Member (Fresh i) r) => Eff r i+fresh = send (inj . Fresh)++-- | Run an effect requiring unique values.+runFresh :: (Typeable i, Enum i) => Eff (Fresh i :> r) w -> i -> Eff r w+runFresh m s0 = loop s0 (admin m)+  where+    loop _ (Val x) = return x+    loop s (E u)   = handleRelay u (loop s) $+                          \(Fresh k) -> (loop $! succ s) (k s)
+ src/Control/Eff/Lift.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+-- | 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)).+module Control.Eff.Lift( Lift+                       , lift+                       , runLift+                       ) where++import Control.Eff+import Data.Typeable++-- | Lift a Monad m to an effect.+data Lift m v = forall a. Lift (m a) (a -> v)++instance Typeable1 m => Typeable1 (Lift m) where+    typeOf1 _ = mkTyConApp (mkTyCon3 "" "Eff" "Lift")+                           [typeOf1 (undefined :: m ())]++instance Functor (Lift m) where+    fmap f (Lift m k) = Lift m (f . k)++-- | Lift a Monad to an Effect.+lift :: (Typeable1 m, Member (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:+-- we only allow a single Lifted Monad.+runLift :: (Monad m, Typeable1 m) => Eff (Lift m :> ()) w -> m w+runLift m = loop (admin m) where+ loop (Val x) = return x+ loop (E u) = prjForce u $ \(Lift m' k) -> m' >>= loop . k
+ src/Control/Eff/State.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Strict state effect+--+-- Example: implementing `Control.Eff.Fresh`+--+-- > runFresh' :: (Typeable i, Enum i, Num i) => Eff (Fresh i :> r) w -> i -> Eff r w+-- > runFresh' m s = fst <$> runState s (loop $ admin m)+-- >  where+-- >   loop (Val x) = return x+-- >   loop (E u)   = case decomp u of+-- >     Right (Fresh k) -> do+-- >                       n <- getState+-- >                       putState (n + 1)+-- >                       loop (k n)+-- >     Left u' -> send (\k -> unsafeReUnion $ k <$> u') >>= loop+module Control.Eff.State(+                        -- * Read-write State+                          State+                        , getState+                        , putState+                        , onState+                        , runState+                        -- * Reader+                        , Reader+                        , getReader+                        , runReader+                        , local+                        -- * Writer+                        , Writer+                        , putWriter+                        , runWriter+                        , runPusher+                        ) where++import Control.Applicative ((<$>), (<|>))+import Data.Typeable++import Control.Eff++-- | Strict state effect+data State s w = State (s -> s) (s -> w)+  deriving (Typeable, Functor)++-- | Write a new value of the state.+putState :: Typeable e => Member (State e) r => e -> Eff r ()+putState = onState . const++-- | Return the current value of the state.+getState :: Typeable e => Member (State e) r => Eff r e+getState = send (inj . State id)++-- | Transform the state with a function.+onState :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r ()+onState f = send (\k -> inj (State f (\_ -> k ())))++-- | Run a State effect.+runState :: Typeable s+         => s                     -- ^ Initial state+         -> Eff (State s :> r) w  -- ^ Effect incorporating State+         -> Eff r (s, w)          -- ^ Effect containing final state and a return value+runState s0 = loop s0 . admin where+ loop s (Val x) = return (s, x)+ loop s (E u)   = handleRelay u (loop s) $+                       \(State t k) -> let s' = t s in s' `seq` loop s' (k s')++-- ------------------------------------------------------------------------+-- The Reader monad++-- | The request for a value of type e from the current environment.+-- This environment is analogous to a parameter of type e.+newtype Reader e v = Reader (e -> v)+    deriving (Typeable, Functor)++-- | Get the current value from a Reader.+getReader :: (Typeable e, Member (Reader e) r) => Eff r e+getReader = send (inj . Reader)++-- | The handler of Reader requests. The return type shows that+-- all Reader requests are fully handled.+runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w+runReader m e = loop (admin m) where+ loop (Val x) = return x+ loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e))++-- | Locally rebind the value in the dynamic environment.+-- This function both requests and admins Reader requests.+local :: (Typeable e, Member (Reader e) r) =>+     (e -> e) -> Eff r a -> Eff r a+local f m = do+  e <- f <$> getReader+  let loop (Val x) = return x+      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))+  loop (admin m)++-- ------------------------------------------------------------------------+-- | The request to remember a value of type e in the current environment+data Writer e v = Writer e v+    deriving (Typeable, Functor)++putWriter :: (Typeable e, Member (Writer e) r) => e -> Eff r ()+putWriter e = send $ \f -> inj $ Writer e $ f ()++-- | Handle Writer requests by overwriting previous values.+-- If no value of type @e@ was returned, Nothing is returned;+-- otherwise return Just the most recent value written.+runWriter :: Typeable e => Eff (Writer e :> r) w -> Eff r (Maybe e, w)+runWriter = loop . admin+  where+    correctVal f = fmap $ \(x, y) -> (f x, y)++    loop (Val x) = return (Nothing, x)+    loop (E u) = handleRelay u loop (\(Writer e v) -> correctVal (<|> Just e) $ loop v)++-- | Handle Writer requests by stacking written values on to a list.+runPusher :: Typeable e => Eff (Writer e :> r) w -> Eff r ([e], w)+runPusher = loop . admin+  where+    loop (Val x) = return ([], x)+    loop (E u) = handleRelay u loop (\(Writer e v) -> (\(es, v') -> (e:es, v')) <$> loop v)
+ src/Control/Eff/Trace.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+-- | A Trace effect for debugging+module Control.Eff.Trace( Trace+                        , trace+                        , runTrace+                        ) where++import Data.Typeable++import Control.Eff++-- | Trace effect for debugging+data Trace v = Trace String (() -> v)+    deriving (Typeable, Functor)++-- | Print a string as a trace.+trace :: Member Trace r => String -> Eff r ()+trace x = send (inj . Trace x)++-- | Run a computation producing Traces.+runTrace :: Eff (Trace :> ()) w -> IO w+runTrace m = loop (admin m)+  where+    loop (Val x) = return x+    loop (E u)   = prjForce u $ \(Trace s k) -> putStrLn s >> loop (k ())
src/Data/OpenUnion1.hs view
@@ -6,18 +6,17 @@ {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} --- | Original work at: http://okmij.org/ftp/Haskell/extensible/OpenUnion1.hs.+-- | 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 -- (or closed type function overlapping soon to be added to GHC).- module Data.OpenUnion1( Union+                      , (:>)                       , inj                       , prj                       , prjForce                       , decomp                       , Member-                      , (:>)                       , unsafeReUnion                       ) where @@ -34,21 +33,20 @@ -- for the sake of gcast1 newtype Id a = Id { runId :: a } --- | Where `r` is `t1 :> t2 ... :> tn`, `Union r v` can be constructed with a--- value of type `ti v`.--- Ideally, we should be be able to add the constraint `Member t r`.+-- | Where @r@ is @t1 :> t2 ... :> tn@, @`Union` r v@ can be constructed with a+-- value of type @ti v@.+-- Ideally, we should be be able to add the constraint @`Member` t r@. data Union r v = forall t. (Functor t, Typeable1 t) => Union (t v)  instance Functor (Union r) where     {-# INLINE fmap #-}     fmap f (Union v) = Union (fmap f v) --- | A sum data type, for `composing' effects--- In GHC 7.4, we should make it a list--- (:>) :: (* -> *) -> (* -> List) -> List+-- | A sum data type, for composing effects infixr 1 :> data ((a :: * -> *) :> b) +-- | There's a @`Member` t r@ instance if t is an element of the sum datatype r. class Member (t :: * -> *) r instance Member t (t :> r) instance Member t r => Member t (t' :> r)@@ -59,16 +57,19 @@ inj = Union  {-# INLINE prj #-}--- | Try extracting the contents of a Union as a specific type.+-- | Try extracting the contents of a Union as a given type. prj :: (Typeable1 t, Member t r) => Union r v -> Maybe (t v) prj (Union v) = runId <$> gcast1 (Id v)  {-# INLINE prjForce #-}--- Like `prj`, but returns an error if the cast fails.+-- | Extract the contents of a Union as a given type.+-- If the Union isn't of that type, a runtime error occurs. prjForce :: (Typeable1 t, Member t r) => Union r v -> (t v -> a) -> a-prjForce u f = f <$> prj u <?> error "prjForce Nothing"+prjForce u f = f <$> prj u <?> error "prjForce with an invalid type"  {-# INLINE decomp #-}+-- | Try extracting the contents of a Union as a given type.+-- If we can't, return a reduced Union that excludes the type we just checked. decomp :: (Typeable1 t, Member t (t :> r)) => Union (t :> r) v -> Either (Union r v) (t v) decomp u = Right <$> prj u <?> Left (unsafeReUnion u)
+ test/Test.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+import Control.Eff+import Control.Eff.Lift+import Control.Eff.State++import Control.Monad (void)+import Data.Typeable++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2++import Test.QuickCheck++main :: IO ()+main = defaultMain tests++allEqual :: Eq a => [a] -> Bool+allEqual = all (uncurry (==)) . pairs+  where+    pairs l = zip l $ tail l++safeLast [] = Nothing+safeLast l = Just $ last l++testDocs :: [Integer] -> Property+testDocs l = let+              (total1, ()) = run $ runState 0 $ sumAll l+              (last1, ()) = run $ runWriter $ writeAll l+              (total2, (last2, ())) = run $ runState 0 $ runWriter $ writeAndAdd l+              (last3, (total3, ())) = run $ runWriter $ runState 0 $ writeAndAdd l+             in allEqual [safeLast l, last1, last2, last3]+           .&&. allEqual [sum l, total1, total2, total3]+  where+    writeAll :: (Typeable a, Member (Writer a) e)+             => [a]+             -> Eff e ()+    writeAll = mapM_ putWriter++    sumAll :: (Typeable a, Num a, Member (State a) e)+           => [a]+           -> Eff e ()+    sumAll = mapM_ (onState . (+))+    +    writeAndAdd :: (Member (Writer Integer) e, Member (State Integer) e)+                => [Integer]+                -> Eff e ()+    writeAndAdd l = do+        writeAll l+        sumAll l++tests = [+    testProperty "Documentation example." testDocs+  ]