diff --git a/extensible-effects.cabal b/extensible-effects.cabal --- a/extensible-effects.cabal +++ b/extensible-effects.cabal @@ -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 + . 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 diff --git a/src/Control/Eff.hs b/src/Control/Eff.hs --- a/src/Control/Eff.hs +++ b/src/Control/Eff.hs @@ -12,66 +12,79 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} --- | Original work available at: http://okmij.org/ftp/Hgetell/extensible/Eff.hs. +-- | Original work available at . -- 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 . -- -- 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 diff --git a/src/Control/Eff/Choose.hs b/src/Control/Eff/Choose.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Choose.hs @@ -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 diff --git a/src/Control/Eff/Coroutine.hs b/src/Control/Eff/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Coroutine.hs @@ -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)) diff --git a/src/Control/Eff/Cut.hs b/src/Control/Eff/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Cut.hs @@ -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 diff --git a/src/Control/Eff/Exception.hs b/src/Control/Eff/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Exception.hs @@ -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) diff --git a/src/Control/Eff/Fresh.hs b/src/Control/Eff/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Fresh.hs @@ -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) diff --git a/src/Control/Eff/Lift.hs b/src/Control/Eff/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Lift.hs @@ -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 diff --git a/src/Control/Eff/State.hs b/src/Control/Eff/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/State.hs @@ -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) diff --git a/src/Control/Eff/Trace.hs b/src/Control/Eff/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Trace.hs @@ -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 ()) diff --git a/src/Data/OpenUnion1.hs b/src/Data/OpenUnion1.hs --- a/src/Data/OpenUnion1.hs +++ b/src/Data/OpenUnion1.hs @@ -6,18 +6,17 @@ {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} --- | Original work at: http://okmij.org/ftp/Haskell/extensible/OpenUnion1.hs. +-- | Original work at . -- 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) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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 + ]