diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg)) +# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg), ![GHC](https://img.shields.io/badge/GHC-8.02%20%7C%208.2.2%20%7C%208.4.4%20%7C%208.6.2-blue.svg)) [![Build Status](https://travis-ci.org/suhailshergill/extensible-effects.svg?branch=master)](https://travis-ci.org/suhailshergill/extensible-effects) [![Join the chat at https://gitter.im/suhailshergill/extensible-effects](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/suhailshergill/extensible-effects?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) @@ -310,8 +310,3 @@ point of having the grouping in the first place. * Code requires a greater number of type annotations. For details see [#31](https://github.com/suhailshergill/extensible-effects/issues/31). - -### Current implementation only supports GHC version 7.8 and above -This is not a fundamental limitation of the design or the approach, but there is -an overhead with making the code compatible across a large number of GHC -versions. If this is needed, patches are welcome :) diff --git a/extensible-effects.cabal b/extensible-effects.cabal --- a/extensible-effects.cabal +++ b/extensible-effects.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 3.1.0.2 +version: 4.0.0.0 -- A short (one-line) description of the package. synopsis: An Alternative to Monad Transformers @@ -41,7 +41,7 @@ category: Control, Effect -tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4 +tested-with: GHC==8.6.2, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 build-type: Simple @@ -56,11 +56,6 @@ default: False manual: True -flag force-openunion-51 - description: Force usage of OpenUnion51.hs implementation - default: False - manual: True - library ghc-options: -Wall -- Modules exported by the library. @@ -71,7 +66,7 @@ Control.Eff.Example Control.Eff.Exception Control.Eff.Fresh - Control.Eff.Lift + Control.Eff.Logic Control.Eff.NdetEff Control.Eff.Operational Control.Eff.Operational.Example @@ -90,8 +85,6 @@ -- Modules included in this library but not exported. other-modules: Control.Eff.Internal Data.FTCQueue - if flag(force-openunion-51) - cpp-options: -DFORCE_OU51 default-extensions: NoMonomorphismRestriction , MonoLocalBinds @@ -128,8 +121,6 @@ , Trustworthy , TypeOperators , UndecidableInstances - if impl(ghc < 7.8.1) - other-extensions: OverlappingInstances if impl(ghc >= 8.2) ghc-options: -Wno-simplifiable-class-constraints @@ -139,9 +130,6 @@ , transformers-base == 0.4.* -- For MonadBaseControl , monad-control >= 1.0 && < 1.1 - if impl(ghc < 8.0) - -- For MonadIO - build-depends: transformers >= 0.2.0.0 -- Directories containing source files. hs-source-dirs: src @@ -149,8 +137,6 @@ -- Base language which the package is written in. default-language: Haskell2010 - -- TODO: uncomment when https://github.com/haskell/cabal/issues/2527 is - -- resolved if flag(lib-Werror) ghc-options: -Werror @@ -166,7 +152,7 @@ , Control.Eff.Example.Test , Control.Eff.Exception.Test , Control.Eff.Fresh.Test - , Control.Eff.Lift.Test + , Control.Eff.NdetEff.Bench , Control.Eff.NdetEff.Test , Control.Eff.Operational.Test , Control.Eff.Reader.Lazy.Test @@ -190,6 +176,7 @@ , QuickCheck , HUnit , monad-control >= 1.0 + , mtl , silently >= 1.2 , test-framework == 0.8.* , test-framework-hunit == 0.3.* @@ -225,7 +212,7 @@ -fno-warn-name-shadowing -fno-warn-unused-matches build-depends: - base >= 4.7 && < 4.12 + base >= 4.7 && < 5 , criterion , extensible-effects , mtl diff --git a/src/Control/Eff.hs b/src/Control/Eff.hs --- a/src/Control/Eff.hs +++ b/src/Control/Eff.hs @@ -24,6 +24,11 @@ ( -- * Effect type Internal.run , Internal.Eff + -- * Lift IO computations + , Internal.lift, Internal.runLift + , Internal.catchDynE + , Internal.HandlerDynE(..), Internal.catchesDynE + , Internal.Lift(..), Internal.Lifted, Internal.LiftedBase -- * Effect list , OpenUnion.Member , OpenUnion.SetMember diff --git a/src/Control/Eff/Choose.hs b/src/Control/Eff/Choose.hs --- a/src/Control/Eff/Choose.hs +++ b/src/Control/Eff/Choose.hs @@ -12,15 +12,17 @@ -- | Nondeterministic choice effect module Control.Eff.Choose ( Choose (..) + , withChoose , choose , makeChoice , mzero' , mplus' + , module Control.Eff.Logic ) where import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift +import Control.Eff.Logic import Control.Applicative import Control.Monad @@ -37,9 +39,17 @@ -- any constraints. newtype Choose a = Choose [a] +-- | Embed a pure value +withChoose :: Monad m => a -> m [a] +withChoose = return . (:[]) +-- | Given a continuation and a Choose request, respond to it. +instance Monad m => Handle Choose (m [a]) where + handle _ (Choose []) = return [] + handle k (Choose [x]) = k x + handle k (Choose lst) = fmap concat $ mapM k lst + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (Choose ': r)) where type StM (Eff (Choose ': r)) a = StM (Eff r) [a] liftBaseWith f = raise $ liftBaseWith $ \runInBase -> @@ -71,11 +81,15 @@ -- | Run a nondeterministic effect, returning all values. makeChoice :: forall a r. Eff (Choose ': r) a -> Eff r [a] -makeChoice = handle_relay - (return . (:[])) - (\(Choose lst) k -> handle lst k) - where - handle :: [t] -> (t -> Eff r [a]) -> Eff r [a] - handle [] _ = return [] - handle [x] k = k x - handle lst k = fmap concat $ mapM k lst +makeChoice = handle_relay withChoose + +instance Member Choose r => MSplit (Eff r) where + msplit = respond_relay (flip withMSplit empty) + (\k (Choose lst) -> hdl k lst) + where + hdl :: Arr r v (Maybe (a, Eff r a)) + -> [v] -> Eff r (Maybe (a, Eff r a)) + hdl _ [] = return Nothing -- definite failure + hdl k (h:t) = k h >>= \r -> case r of -- possibility + Nothing -> hdl k t -- failure, continue exploring + Just (a, m) -> withMSplit a (m <|> (hdl k t >>= reflect)) -- definite success diff --git a/src/Control/Eff/Coroutine.hs b/src/Control/Eff/Coroutine.hs --- a/src/Control/Eff/Coroutine.hs +++ b/src/Control/Eff/Coroutine.hs @@ -5,6 +5,7 @@ {-# LANGUAGE Safe #-} -- | Coroutines implemented with extensible effects module Control.Eff.Coroutine( Yield (..) + , withCoroutine , yield , runC , Y (..) @@ -35,13 +36,16 @@ -- -- Type parameter @w@ is the type of the value returned from the -- coroutine when it has completed. -data Y r a w = Y a (w -> Eff r (Y r a w)) +data Y r w a = Y (w -> Eff r (Y r w a)) a | Done +-- | Return a pure value +withCoroutine :: Monad m => b -> m (Y r w a) +withCoroutine = const $ return Done +-- | Given a continuation and a request, respond to it +instance Handle (Yield a b) (Eff r (Y r b a)) where + handle k (Yield a) = return $ Y k a -- | Launch a thread and report its status -runC :: Eff (Yield a b ': r) w -> Eff r (Y r a b) -runC m = handle_relay - (const $ return Done) - (\(Yield a) k -> return $ Y a k) - m +runC :: Eff (Yield a b ': r) w -> Eff r (Y r b a) +runC = handle_relay withCoroutine diff --git a/src/Control/Eff/Cut.hs b/src/Control/Eff/Cut.hs --- a/src/Control/Eff/Cut.hs +++ b/src/Control/Eff/Cut.hs @@ -44,12 +44,18 @@ import Control.Eff.Extend import Control.Eff.Exception import Control.Eff.Choose +import Control.Monad data CutFalse = CutFalse cutfalse :: Member (Exc CutFalse) r => Eff r a cutfalse = throwError CutFalse +-- | Prolog 'cut', taken from Hinze 2000 (Deriving backtracking monad +-- transformers). +(!) :: (Member (Exc CutFalse) r, MonadPlus (Eff r)) => Eff r () +(!) = return () `mplus` 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 @@ -66,7 +72,7 @@ -> Eff (Exc CutFalse ': r) a -> Eff r a loop jq (Val x) = return x `mplus'` next jq -- (C2) - loop jq (E u q) = case decomp u of + loop jq (E q u) = case decomp u of Right (Exc CutFalse) -> mzero' -- drop jq (F2) Left u0 -> check jq u0 q @@ -75,7 +81,7 @@ check jq u _ | Just (Choose []) <- prj u = next jq -- (C1) check jq u q | Just (Choose [x]) <- prj u = loop jq (q ^$ x) -- (C3), optim check jq u q | Just (Choose lst) <- prj u = next $ map (q ^$) lst ++ jq -- (C3) - check jq u q = loop jq (E (weaken u) q) -- (C4) + check jq u q = loop jq (E q (weaken u)) -- (C4) next :: Member Choose r => [Eff (Exc CutFalse ': r) a] diff --git a/src/Control/Eff/Example.hs b/src/Control/Eff/Example.hs --- a/src/Control/Eff/Example.hs +++ b/src/Control/Eff/Example.hs @@ -82,14 +82,14 @@ handUp :: Eff (Move ': r) a -> Eff r a handUp (Val x) = return x -handUp (E u q) = case decomp u of +handUp (E q u) = case decomp u of Right Move -> handDown $ qApp q () -- Relay other requests - Left u0 -> E u0 ident >>= handUp . qApp q + Left u0 -> E ident u0 >>= handUp . qApp q handDown :: Eff (Move ': r) a -> Eff r a handDown (Val x) = return x -handDown (E u q) = case decomp u of +handDown (E q u) = case decomp u of Right Move -> handUp $ qApp q () -- Relay other requests - Left u0 -> E u0 ident >>= handDown . qApp q + Left u0 -> E ident u0 >>= handDown . qApp q diff --git a/src/Control/Eff/Exception.hs b/src/Control/Eff/Exception.hs --- a/src/Control/Eff/Exception.hs +++ b/src/Control/Eff/Exception.hs @@ -8,6 +8,8 @@ {-# LANGUAGE Safe #-} -- | Exception-producing and exception-handling effects module Control.Eff.Exception ( Exc (..) + , exc + , withException , Fail , throwError , throwError_ @@ -26,7 +28,6 @@ import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Monad (void) import Control.Monad.Base @@ -38,9 +39,22 @@ -- exceptions of the type e; no resumption newtype Exc e v = Exc e +-- | Embed a pure value +withException :: Monad m => a -> m (Either e a) +withException = return . Right +-- | Throw an error +exc :: Monad m => e -> m (Either e a) +exc = return . Left +-- | Given a callback, and an 'Exc' request, respond to it. +instance Monad m => Handle (Exc e) (m (Either e a)) where + handle _ (Exc e) = exc e + +-- runError :: (a -> m (Either e a)), (e -> m (Either e a)) +-- catchError :: (a -> Eff r a), (e -> Eff r a) +-- exc :: e -> m (Either e a) + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (Exc e ': r)) where type StM (Eff (Exc e ': r)) a = StM (Eff r) (Either e a) liftBaseWith f = raise $ liftBaseWith $ \runInBase -> @@ -69,9 +83,7 @@ -- | Run a computation that might produce an exception. runError :: Eff (Exc e ': r) a -> Eff r (Either e a) -runError = handle_relay - (return . Right) - (\(Exc e) _k -> return (Left e)) +runError = handle_relay withException -- | Runs a failable effect, such that failed computation return 'Nothing', and -- 'Just' the return value on success. @@ -84,14 +96,14 @@ -- exception catchError :: Member (Exc e) r => Eff r a -> (e -> Eff r a) -> Eff r a -catchError m handle = interpose return (\(Exc e) _k -> handle e) m +catchError m h = respond_relay return (\_ (Exc e) -> h e) m -- | 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 +onFail e handle_ = runFail e >>= maybe handle_ return {-# INLINE onFail #-} -- | Run a computation until it produces an exception, @@ -100,7 +112,7 @@ => (e -> e') -> Eff (Exc e ': r) a -> Eff r a -rethrowError t eff = runError eff >>= either (throwError . t) return +rethrowError t e = runError e >>= either (throwError . t) return -- | Treat Lefts as exceptions and Rights as return values. liftEither :: (Member (Exc e) r) => Either e a -> Eff r a @@ -108,7 +120,7 @@ {-# INLINE liftEither #-} -- | `liftEither` in a lifted Monad -liftEitherM :: (Member (Exc e) r, SetMember Lift (Lift m) r) +liftEitherM :: (Member (Exc e) r, Lifted m r) => m (Either e a) -> Eff r a liftEitherM m = lift m >>= liftEither @@ -120,7 +132,7 @@ {-# INLINE liftMaybe #-} -- | `liftMaybe` in a lifted Monad -liftMaybeM :: (Member Fail r, SetMember Lift (Lift m) r) +liftMaybeM :: (Member Fail r, Lifted m r) => m (Maybe a) -> Eff r a liftMaybeM m = lift m >>= liftMaybe diff --git a/src/Control/Eff/Extend.hs b/src/Control/Eff/Extend.hs --- a/src/Control/Eff/Extend.hs +++ b/src/Control/Eff/Extend.hs @@ -6,6 +6,12 @@ ( -- * The effect monad Eff(..) , run + , eff, impurePrj, impureDecomp + -- * Lifting operations + , Lift(..), Lifted, LiftedBase + , lift, runLift + , catchDynE + , HandlerDynE(..), catchesDynE -- * Open Unions , OpenUnion.Union , OpenUnion.Member @@ -15,9 +21,12 @@ , SetMember , weaken -- * Helper functions that are used for implementing effect-handlers + , Handle, handle + , Relay, relay , handle_relay - , handle_relay_s - , interpose + , handle_relay' + , respond_relay + , respond_relay' , raise , send -- * Arrow types and compositions @@ -32,7 +41,8 @@ , comp , (^|>) , qComp - , qComps + , qComps, (^|$^) + , (~^), qThen, andThen ) where diff --git a/src/Control/Eff/Fresh.hs b/src/Control/Eff/Fresh.hs --- a/src/Control/Eff/Fresh.hs +++ b/src/Control/Eff/Fresh.hs @@ -9,13 +9,13 @@ {-# LANGUAGE Safe #-} -- | Create unique Enumerable values. module Control.Eff.Fresh( Fresh (Fresh) + , withFresh , fresh , runFresh' ) where import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Monad.Base import Control.Monad.Trans.Control @@ -35,14 +35,23 @@ Fresh :: Fresh Int Replace :: !Int -> Fresh () +-- | Embed a pure value. Note that this is a specialized form of +-- State's and we could have reused it. +withFresh :: Monad m => a -> Int -> m (a, Int) +withFresh x s = return (x, s) + +-- | Given a continuation and requests, respond to them +instance Handle Fresh (Int -> r) where + handle k Fresh s = k s (s + 1) + handle k (Replace i) _ = k () i + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (Fresh ': r)) where type StM (Eff (Fresh ': r)) a = StM (Eff r) (a, Int) liftBaseWith f = do i <- fresh raise $ liftBaseWith $ \runInBase -> - f (\k -> runInBase $ runFreshReturn k i) + f (\k -> runInBase $ runFreshReturn i k) restoreM x = do (r,i) <- raise (restoreM x) replace i return r @@ -56,16 +65,12 @@ replace = send . Replace -- | Run an effect requiring unique values. -runFresh' :: Eff (Fresh ': r) w -> Int -> Eff r w -runFresh' m s = fst `fmap` runFreshReturn m s +runFresh' :: Int -> Eff (Fresh ': r) w -> Eff r w +runFresh' s m = fst `fmap` runFreshReturn s m -runFreshReturn :: Eff (Fresh ': r) w -> Int -> Eff r (w,Int) -runFreshReturn m s = - handle_relay_s s (\s' x -> return (x,s')) - (\s' e k -> case e of - Fresh -> (k $! s' + 1) s' - Replace i -> k i ()) - m +runFreshReturn :: Int -> Eff (Fresh ': r) w -> Eff r (w,Int) +runFreshReturn s m = handle_relay withFresh m s + {- -- Finally, the worst implementation but the one that answers -- reviewer's question: implementing Fresh in terms of State diff --git a/src/Control/Eff/Internal.hs b/src/Control/Eff/Internal.hs --- a/src/Control/Eff/Internal.hs +++ b/src/Control/Eff/Internal.hs @@ -7,8 +7,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- ------------------------------------------------------------------------ -- | A monadic library for communication between a handler and @@ -24,17 +25,16 @@ -- effects, consult the tests. module Control.Eff.Internal where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import qualified Control.Arrow as A import qualified Control.Category as C import Control.Monad.Base (MonadBase(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) +import qualified Control.Exception as Exc import safe Data.OpenUnion import safe Data.FTCQueue import GHC.Exts (inline) +import Data.Function (fix) -- | Effectful arrow type: a function from a to b that also does effects -- denoted by r @@ -65,6 +65,9 @@ {-# INLINE singleK #-} singleK :: Arr r a b -> Arrs r a b singleK = Arrs . tsingleton +{-# INLINE (~^) #-} +(~^) :: Arr r a b -> Arrs r a b +(~^) = singleK -- | Application to the `generalized effectful function' Arrs r b w, i.e., -- convert 'Arrs' to 'Arr' @@ -75,7 +78,7 @@ cons :: forall x. Arr r b x -> FTCQueue (Eff r) x w -> Eff r w cons = \k t -> case k x of Val y -> qApp (Arrs t) y - E u (Arrs q0) -> E u (Arrs (q0 >< t)) + E (Arrs q0) u -> E (Arrs (q0 >< t)) u {- -- A bit more understandable version qApp :: Arrs r b w -> b -> Eff r w @@ -121,65 +124,91 @@ -- of the effects' @run*@ functions before unwrapping the final result. -- For additional details, see the documentation of the effects you are using. data Eff r a = Val a - | forall b. E (Union r b) (Arrs r b a) + | forall b. E (Arrs r b a) (Union r b) +-- | Case analysis for 'Eff' datatype. If the value is @'Val' a@ apply +-- the first function to @a@; if it is @'E' u q@, apply the second +-- function. +{-# INLINE eff #-} +eff :: (a -> b) + -> (forall v. Arrs r v a -> Union r v -> b) + -> Eff r a -> b +eff f _ (Val a) = f a +eff _ g (E q u) = g q u +-- | The usual 'bind' fnuction with arguments flipped. This is a +-- common pattern for Eff. +{-# INLINE bind #-} +bind :: Arr r a b -> Eff r a -> Eff r b +bind k = eff k (E . (^|> k)) -- just accumulates continuations + +-- | Case analysis for impure computations for 'Eff' datatype. This +-- uses 'decomp'. +{-# INLINE impureDecomp #-} +impureDecomp :: (Arrs (t ': r) v a -> t v -> b) + -> (Arrs (t ': r) v a -> Union r v -> b) + -> Arrs (t ': r) v a -> Union (t ': r) v -> b +impureDecomp h rest q u = either (rest q) (h q) (decomp u) +-- | Case analysis for impure computations for 'Eff' datatype. This +-- uses 'prj'. +{-# INLINE impurePrj #-} +impurePrj :: Member t r + => (Arrs r v a -> t v -> b) + -> (Arrs r v a -> Union r v -> b) + -> Arrs r v a -> Union r v -> b +impurePrj h def q u = maybe (def q u) (h q) (prj u) + -- | Compose effectful arrows (and possibly change the effect!) {-# INLINE qComp #-} -qComp :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arr r' a c +qComp :: Arrs r a b -> (Eff r b -> k) -> (a -> k) -- qComp g h = (h . (g `qApp`)) qComp g h = \a -> h $ (g ^$ a) +{-# INLINABLE qThen #-} +qThen :: (Eff r b -> k) -> Arrs r a b -> (a -> k) +qThen = flip qComp +-- | Compose and then apply to function. This is a common pattern when +-- processing requests. Different options of 'f' allow us to handle or +-- relay the request and continue on. +andThen :: ((b -> c) -> t) -> (Eff r w -> c) + -> Arrs r b w -> t +andThen f next = f . (qThen next) + -- | Compose effectful arrows (and possibly change the effect!) {-# INLINE qComps #-} qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c qComps g h = singleK $ qComp g h +{-# INLINABLE (^|$^) #-} +(^|$^) :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c +(^|$^) = qComps instance Functor (Eff r) where {-# INLINE fmap #-} - fmap f (Val x) = Val (f x) - fmap f (E u q) = E u (q ^|> (Val . f)) -- does no mapping yet! + fmap f = bind (Val . f) instance Applicative (Eff r) where {-# INLINE pure #-} pure = Val - Val f <*> e = f `fmap` e - E u q <*> e = E u (q ^|> (`fmap` e)) + mf <*> e = bind (`fmap` e) mf instance Monad (Eff r) where {-# INLINE return #-} {-# INLINE [2] (>>=) #-} return = pure - Val x >>= k = k x - E u q >>= k = E u (q ^|> k) -- just accumulates continuations + (>>=) = flip bind {- Val _ >> m = m - E u q >> m = E u (q ^|> const m) + E q u >> m = E (q ^|> const m) u -} -instance (MonadBase b m, SetMember Lift (Lift m) r) => MonadBase b (Eff r) where - liftBase = lift . liftBase - {-# INLINE liftBase #-} - -instance (MonadBase m m) => MonadBaseControl m (Eff '[Lift m]) where - type StM (Eff '[Lift m]) a = a - liftBaseWith f = lift (f runLift) - {-# INLINE liftBaseWith #-} - restoreM = return - {-# INLINE restoreM #-} - -instance (MonadIO m, SetMember Lift (Lift m) r) => MonadIO (Eff r) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -- | Send a request and wait for a reply (resulting in an effectful -- computation). {-# INLINE [2] send #-} send :: Member t r => t v -> Eff r v -send t = E (inj t) (singleK Val) +send t = E (singleK Val) (inj t) -- This seems to be a very beneficial rule! On micro-benchmarks, cuts -- the needed memory in half and speeds up almost twice. {-# RULES - "send/bind" [~3] forall t k. send t >>= k = E (inj t) (singleK k) + "send/bind" [~3] forall t k. send t >>= k = E (singleK k) (inj t) #-} @@ -195,79 +224,154 @@ -- cannot terminate. -- To extract the true error, the evaluation of union is forced. -- 'run' is a total function if its argument is different from bottom. -run (E union _) = +run (E _ union) = union `seq` error "extensible-effects: the impossible happened!" --- | A convenient pattern: given a request (open union), either --- handle it or relay it. -{-# INLINE handle_relay #-} -handle_relay :: (a -> Eff r w) -> - (forall v. t v -> Arr r v w -> Eff r w) -> - Eff (t ': r) a -> Eff r w -handle_relay ret h m = loop m - where - loop (Val x) = ret x - loop (E u q) = case decomp u of - Right x -> h x k - Left u0 -> E u0 (singleK k) - where k = qComp q loop +-- | Abstract the recursive 'relay' pattern, i.e., "somebody else's +-- problem". +class Relay k r where + relay :: (v -> k) -> Union r v -> k +instance Relay (Eff r w) r where + relay q u = E (singleK q) u +instance Relay k r => Relay (s -> k) r where + relay q u s = relay (\x -> q x s) u --- | Parameterized handle_relay -{-# INLINE handle_relay_s #-} -handle_relay_s :: s -> - (s -> a -> Eff r w) -> - (forall v. s -> t v -> (s -> Arr r v w) -> Eff r w) -> - Eff (t ': r) a -> Eff r w -handle_relay_s s ret h m = loop s m +-- | Respond to requests of type 't'. +class Handle t k where + handle :: (v -> k) -> t v -> k + +-- | A convenient pattern: given a request (in an open union), either +-- handle it (using default Handler) or relay it. +-- +-- "Handle" implies that all requests of type @t@ are dealt with, +-- i.e., @k@ (the response type) doesn't have @t@ as part of its +-- effect list. The @Relay k r@ constraint ensures that @k@ is an +-- effectful computation (with effectlist @r@). +-- +-- Note that we can only handle the leftmost effect type (a +-- consequence of the 'OpenUnion' implementation. +handle_relay :: forall t k r a. Handle t k => Relay k r + => (a -> k) -- ^ return + -> Eff (t ': r) a -> k +handle_relay ret = handle_relay' ret handle + +-- | A less commonly needed variant with an explicit handler (instead +-- of @Handle t k@ constraint). +handle_relay' :: forall t k r a. Relay k r + => (a -> k) -- ^ return + -> (forall v. (v -> k) -> t v -> k) -- ^ handler + -> Eff (t ': r) a -> k +handle_relay' ret h = fix step where - loop s0 (Val x) = ret s0 x - loop s0 (E u q) = case decomp u of - Right x -> h s0 x k - Left u0 -> E u0 (singleK (k s0)) - where k s1 x = loop s1 $ qApp q x + step next = eff ret + (impureDecomp + (h `andThen` next) + (relay `andThen` next)) --- Add something like Control.Exception.catches? It could be useful --- for control with cut. +-- | Intercept the request and possibly respond to it, but leave it +-- unhandled. The @Relay k r@ constraint ensures that @k@ is an +-- effectful computation (with effectlist @r@). As such, the effect +-- type @t@ will show up in the response type @k@. +respond_relay :: Member t r => Relay k r + => (a -> k) + -> (forall v. (v -> k) -> t v -> k) + -> Eff r a -> k +respond_relay ret h = fix step + where + step next = eff ret + (impurePrj + (h `andThen` next) + (relay `andThen` next)) --- | Intercept the request and possibly reply to it, but leave it unhandled --- (that's why the same r is used all throuout) -{-# INLINE interpose #-} -interpose :: Member t r => - (a -> Eff r w) -> (forall v. t v -> Arr r v w -> Eff r w) -> - Eff r a -> Eff r w -interpose ret h m = loop m - where - loop (Val x) = ret x - loop (E u q) = case prj u of - Just x -> h x k - _ -> E u (singleK k) - where k = qComp q loop +-- | A less common variant which uses the default 'handle' from the +-- @Handle t k@ instance (in general, we may need to define new +-- datatypes to call respond_relay with the default handler). +respond_relay' :: forall t k r a. (Member t r, Handle t k, Relay k r) + => (a -> k) + -> Eff r a -> k +respond_relay' ret = respond_relay ret (handle @t) -- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to -- MTL's 'lift'. raise :: Eff r a -> Eff (e ': r) a -raise = loop +raise = fix step where - loop (Val x) = pure x - loop (E u q) = E (weaken u) $ qComps q loop + step next = eff pure + (\q -> ((E . (~^) . (qThen next)) q) . weaken) {-# INLINE raise #-} -- ------------------------------------------------------------------------ -- | Lifting: emulating monad transformers -newtype Lift m a = Lift (m a) +newtype Lift m a = Lift { unLift :: m a } +-- |A convenient alias to 'SetMember Lift (Lift m) r', which allows us +-- to assert that the lifted type occurs ony once in the effect list. +type Lifted m r = SetMember Lift (Lift m) r + +-- |Same as 'Lifted' but with additional 'MonadBaseControl' constraint +type LiftedBase m r = ( SetMember Lift (Lift m) r + , MonadBaseControl m (Eff r) + ) + -- | embed an operation of type `m a` into the `Eff` monad when @Lift m@ is in -- a part of the effect-list. --- --- By using SetMember, it is possible to assert that the lifted type occurs --- only once in the effect list -lift :: (SetMember Lift (Lift m) r) => m a -> Eff r a +lift :: Lifted m r => m a -> Eff r a lift = send . Lift --- | The handler of Lift requests. It is meant to be terminal: --- we only allow a single Lifted Monad. +-- | Handle lifted requests by running them sequentially +instance Monad m => Handle (Lift m) (m k) where + handle k (Lift x) = x >>= k + +-- | The handler of Lift requests. It is meant to be terminal: we only +-- allow a single Lifted Monad. Note, too, how this is different from +-- other handlers. runLift :: Monad m => Eff '[Lift m] w -> m w -runLift (Val x) = return x -runLift (E u q) = case prj u of - Just (Lift m) -> m >>= runLift . qApp q - Nothing -> error "Impossible: Nothing cannot occur" +runLift = fix step + where + step :: Monad m => (Eff '[Lift m] w -> m w) -> Eff '[Lift m] w -> m w + step next = eff return + (impurePrj + (handle `andThen` next) + (\_ _ -> error "Impossible: Nothing to relay!") + ) + +-- | Catching of dynamic exceptions +-- See the problem in +-- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO +catchDynE :: forall e a r. + (Lifted IO r, Exc.Exception e) => + Eff r a -> (e -> Eff r a) -> Eff r a +catchDynE m eh = respond_relay return h m + where + -- Polymorphic local binding: signature is needed + h :: Arr r v a -> Lift IO v -> Eff r a + h k (Lift em) = lift (Exc.try em) >>= either eh k + +-- | You need this when using 'catches'. +data HandlerDynE r a = + forall e. (Exc.Exception e, Lifted IO r) => HandlerDynE (e -> Eff r a) + +-- | Catch multiple dynamic exceptions. The implementation follows +-- that in Control.Exception almost exactly. Not yet tested. +-- Could this be useful for control with cut? +catchesDynE :: Lifted IO r => Eff r a -> [HandlerDynE r a] -> Eff r a +catchesDynE m hs = m `catchDynE` catchesHandler hs where + catchesHandler :: Lifted IO r => [HandlerDynE r a] -> Exc.SomeException -> Eff r a + catchesHandler handlers e = foldr tryHandler (lift . Exc.throw $ e) handlers + where + tryHandler (HandlerDynE h) res = maybe res h (Exc.fromException e) + +instance (MonadBase b m, Lifted m r) => MonadBase b (Eff r) where + liftBase = lift . liftBase + {-# INLINE liftBase #-} + +instance (MonadBase m m) => MonadBaseControl m (Eff '[Lift m]) where + type StM (Eff '[Lift m]) a = a + liftBaseWith f = lift (f runLift) + {-# INLINE liftBaseWith #-} + restoreM = return + {-# INLINE restoreM #-} + +instance (MonadIO m, Lifted m r) => MonadIO (Eff r) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} diff --git a/src/Control/Eff/Lift.hs b/src/Control/Eff/Lift.hs deleted file mode 100644 --- a/src/Control/Eff/Lift.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE Safe #-} --- | 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 (..) - , Lifted - , LiftedBase - , lift - , runLift - , catchDynE - ) where - -import Control.Eff.Internal -import qualified Control.Exception as Exc -import Data.OpenUnion - -import Control.Monad.Trans.Control (MonadBaseControl) - --- |A convenient alias to 'SetMember Lift (Lift m) r' -type Lifted m r = SetMember Lift (Lift m) r - --- |Same as 'Lifted' but with additional 'MonadBaseControl' constraint -type LiftedBase m r = ( SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) - ) - --- | Catching of dynamic exceptions --- See the problem in --- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO -catchDynE :: forall e a r. - (Lifted IO r, Exc.Exception e) => - Eff r a -> (e -> Eff r a) -> Eff r a -catchDynE m eh = interpose return h m - where - -- Polymorphic local binding: signature is needed - h :: Lift IO v -> Arr r v a -> Eff r a - h (Lift em) k = lift (Exc.try em) >>= \x -> case x of - Right x0 -> k x0 - Left e -> eh e diff --git a/src/Control/Eff/Logic.hs b/src/Control/Eff/Logic.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE Safe #-} + +-- | Logic primitives. See LogicT paper for details. +module Control.Eff.Logic where + +import Control.Monad +import Data.Function (fix) + +-- | The MSplit primitive from LogicT paper. +class MSplit m where + -- | The laws for 'msplit' are: + -- + -- 1] msplit mzero == return Nothing + -- 2] msplit (return a `mplus` m) == return (Just(a, m)) + msplit :: m a -> m (Maybe (a, m a)) + +-- | Embed a pure value into MSplit +withMSplit :: MonadPlus m => a -> m a -> m (Maybe (a, m a)) +withMSplit a rest = return (Just (a, rest)) +-- The handlers are defined in terms of the specific non-determinism +-- effects (instead of by way of a distinct MSplit handler + +reflect :: MonadPlus m => Maybe (a, m a) -> m a +reflect Nothing = mzero +reflect (Just (a,m)) = return a `mplus` m + +-- Other committed choice primitives can be implemented in terms of msplit +-- The following implementations are directly from the LogicT paper + +-- | Soft-cut: non-deterministic if-then-else, aka Prolog's *-> +-- Declaratively, +-- ifte t th el = (t >>= th) `mplus` ((not t) >> el) +-- However, t is evaluated only once. In other words, ifte t th el +-- is equivalent to t >>= th if t has at least one solution. +-- If t fails, ifte t th el is the same as el. +-- +-- Laws: +-- 1] ifte (return a) th el == th a +-- 2] ifte mzero th el == el +-- 3] ifte (return a `mplus` m) th el == th a `mplus` (m >>= th) +ifte :: (MonadPlus m, MSplit m) + => m t -> (t -> m b) -> m b -> m b +ifte t th el = msplit t >>= check + where check Nothing = el + check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th) + +-- | Another pruning operation (ifte is the other). This selects one +-- solution out of possibly many. +once :: (MSplit m, MonadPlus m) => m b -> m b +once m = msplit m >>= check + where check Nothing = mzero + check (Just (sg1,_)) = return sg1 + +-- | Negation as failure +gnot :: (MonadPlus m, MSplit m) => m b -> m () +gnot m = ifte (once m) (const mzero) (return ()) + +-- | Fair (i.e., avoids starvation) disjunction. It obeys the +-- following laws: +-- +-- 1] interleave mzero m == m +-- 2] interleave (return a `mplus` m1) m2 == return a `mplus` (interleave m2 m1) +-- +-- corollary: +-- interleave m mzero == m +interleave :: (MSplit m, MonadPlus m) => m b -> m b -> m b +interleave sg1 sg2 = + do r <- msplit sg1 + case r of + Nothing -> sg2 + Just (sg11,sg12) -> + (return sg11) `mplus` (interleave sg2 sg12) + +-- | Fair (i.e., avoids starvation) conjunction. It obeys the +-- following laws: +-- +-- 1] mzero >>- k == mzero +-- 2] (return a `mplus` m) >>- k == interleave (k a) (m >>- k) +(>>-) :: (MonadPlus m, MSplit m) => m a -> (a -> m b) -> m b +sg >>- g = + do r <- msplit sg + case r of + Nothing -> mzero + Just (sg1 ,sg2) -> interleave (g sg1) (sg2 >>- g) + +-- | Collect all solutions. This is from Hinze's 'Backtr' monad +-- class. Unsurprisingly, this can be implemented in terms of msplit. +-- +-- TODO: use a more efficient data structure. +sols :: (MonadPlus m, MSplit m) => m a -> m [a] +sols m = (msplit m) >>= (fix step) [] where + step _ jq Nothing = return jq + step next jq (Just(a, ma)) = (msplit ma) >>= next (a:jq) diff --git a/src/Control/Eff/NdetEff.hs b/src/Control/Eff/NdetEff.hs --- a/src/Control/Eff/NdetEff.hs +++ b/src/Control/Eff/NdetEff.hs @@ -13,11 +13,20 @@ {-# LANGUAGE UndecidableInstances #-} -- | Another implementation of nondeterministic choice effect -module Control.Eff.NdetEff where +module Control.Eff.NdetEff ( + NdetEff + , withNdetEff + , left, right + , makeChoiceA + , makeChoiceA0 + , makeChoiceLst + , msplit1 + , module Control.Eff.Logic + ) where import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift +import Control.Eff.Logic import Control.Applicative import Control.Monad @@ -31,6 +40,20 @@ MZero :: NdetEff a MPlus :: NdetEff Bool +-- | How to embed a pure value in non-deterministic context +withNdetEff :: Alternative f => Monad m => a -> m (f a) +withNdetEff = return . pure +-- | The left branch +left :: (Bool -> k) -> k +left k = k True +-- | The right branch +right :: (Bool -> k) -> k +right k = k False +-- | Given a callback and NdetEff requests respond to them +instance (Alternative f, Monad m) => Handle NdetEff (m (f a)) where + handle _ MZero = return empty + handle k MPlus = liftM2 (<|>) (left k) (right k) + instance Member NdetEff r => Alternative (Eff r) where empty = mzero (<|>) = mplus @@ -40,8 +63,7 @@ mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2 instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (NdetEff ': r)) where type StM (Eff (NdetEff ': r)) a = StM (Eff r) [a] liftBaseWith f = raise $ liftBaseWith $ \runInBase -> @@ -54,66 +76,53 @@ -- The cause probably is mapping every failure to empty -- It takes then a lot of timne and space to store those empty makeChoiceA0 :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a) -makeChoiceA0 = handle_relay (return . pure) $ \m k -> case m of - MZero -> return empty - MPlus -> liftM2 (<|>) (k True) (k False) +makeChoiceA0 = handle_relay withNdetEff -- | A different implementation, more involved but faster and taking -- much less (100 times) less memory. -- The benefit of the effect framework is that we can have many -- interpreters. makeChoiceA :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a) -makeChoiceA m = loop [] m - where - loop [] (Val x) = return (pure x) - loop (h:t) (Val x) = loop t h >>= \r -> return (pure x <|> r) - loop jq (E u q) = case decomp u of - Right MZero -> case jq of - [] -> return empty - (h:t) -> loop t h - Right MPlus -> loop (q ^$ False : jq) (q ^$ True) - Left u0 -> E u0 (singleK (\x -> loop jq (q ^$ x))) +makeChoiceA m = loop [] m where + loop [] (Val x) = withNdetEff x + loop (h:t) (Val x) = liftM2 (<|>) (withNdetEff x) (loop t h) + loop jq (E q u) = case decomp u of + Right MZero -> case jq of + [] -> return empty + (h:t) -> loop t h + Right MPlus -> loop (q ^$ False : jq) (q ^$ True) + Left u0 -> E (q ^|$^ (loop jq)) u0 -- | Same as makeChoiceA, except it has the type hardcoded. -- Required for MonadBaseControl instance. makeChoiceLst :: Eff (NdetEff ': r) a -> Eff r [a] makeChoiceLst = makeChoiceA --- ------------------------------------------------------------------------ --- Soft-cut: non-deterministic if-then-else, aka Prolog's *-> --- Declaratively, --- ifte t th el = (t >>= th) `mplus` ((not t) >> el) --- However, t is evaluated only once. In other words, ifte t th el --- is equivalent to t >>= th if t has at least one solution. --- If t fails, ifte t th el is the same as el. --- We actually implement LogicT, the non-determinism reflection, --- of which soft-cut is one instance. --- See the LogicT paper for an explanation -msplit :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a)) -msplit = loop [] +-- | We actually implement LogicT, the non-determinism reflection, of +-- which soft-cut is one instance. Straightforward implementation +-- using 'respond_relay'. See the LogicT paper for an explanation. +instance Member NdetEff r => MSplit (Eff r) where + msplit = respond_relay (flip withMSplit empty) $ \k x -> case x of + MZero -> return Nothing -- definite failure + MPlus -> left k >>= \r -> case r of -- check left first + Nothing -> right k -- failure, continue exploring + Just(a, m) -> withMSplit a (m <|> (right k >>= reflect)) -- definite success + +-- | A different implementation, more involved. Unclear whether this +-- is faster or not. +msplit1 :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a)) +msplit1 = loop [] where - -- singleK result - loop [] (Val x) = return (Just (x,mzero)) + -- single result + loop [] (Val x) = withMSplit x mzero -- definite result and perhaps some others - loop jq (Val x) = return (Just (x, msum jq)) + loop jq (Val x) = withMSplit x (msum jq) -- not yet definite answer - loop jq (E u q) = case prj u of + loop jq (E q u) = case prj u of Just MZero -> case jq of -- no futher choices [] -> return Nothing -- other choices remain, try them (j:jqT) -> loop jqT j Just MPlus -> loop ((q ^$ False):jq) (q ^$ True) - _ -> E u (qComps q (loop jq)) - --- Other committed choice primitives can be implemented in terms of msplit --- The following implementations are directly from the LogicT paper -ifte :: Member NdetEff r => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b -ifte t th el = msplit t >>= check - where check Nothing = el - check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th) - -once :: Member NdetEff r => Eff r a -> Eff r a -once m = msplit m >>= check - where check Nothing = mzero - check (Just (sg1,_)) = return sg1 + _ -> E (q ^|$^ (loop jq)) u diff --git a/src/Control/Eff/Operational.hs b/src/Control/Eff/Operational.hs --- a/src/Control/Eff/Operational.hs +++ b/src/Control/Eff/Operational.hs @@ -5,13 +5,13 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | Operational Monad () implemented with -- extensible effects. module Control.Eff.Operational ( Program (..) + , withOperational, Intrprtr (..) , singleton , runProgram -- * Usage @@ -26,16 +26,23 @@ data Program instr v where Singleton :: instr a -> Program instr a +-- | General form of an interpreter +newtype Intrprtr f r = Intrprtr { runIntrprtr :: forall x. f x -> Eff r x } + +-- | Embed a pure value +withOperational :: a -> Intrprtr f r -> Eff r a +withOperational x _ = return x +-- | Given a continuation and a program, interpret it +instance Handle (Program f) (Intrprtr f r -> Eff r a) where + handle k (Singleton instr) i = (runIntrprtr i) instr >>= (flip k i) + -- | Lift a value to a monad. singleton :: (Member (Program instr) r) => instr a -> Eff r a singleton = send . Singleton -- | Convert values using given interpreter to effects. runProgram :: forall f r a. (forall x. f x -> Eff r x) -> Eff (Program f ': r) a -> Eff r a -runProgram advent = handle_relay return h - where - h :: forall v. Program f v -> (v -> Eff r a) -> Eff r a - h (Singleton instr) k = advent instr >>= k +runProgram advent m = handle_relay withOperational m (Intrprtr advent) -- $usage -- diff --git a/src/Control/Eff/Operational/Example.hs b/src/Control/Eff/Operational/Example.hs --- a/src/Control/Eff/Operational/Example.hs +++ b/src/Control/Eff/Operational/Example.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | Example usage of "Control.Eff.Operational". @@ -8,7 +7,6 @@ import Control.Eff.Operational import Control.Eff -import Control.Eff.Lift import Control.Eff.Writer.Lazy import Control.Eff.State.Lazy @@ -25,11 +23,11 @@ singleton $ Print ("the input is " ++ str) -- | Then, implements interpreters from the data to effects. -adventIO :: (SetMember Lift (Lift IO) r) => Jail a -> Eff r a +adventIO :: Lifted IO r => Jail a -> Eff r a adventIO (Print a) = lift $ putStrLn a adventIO Scan = lift getLine -adventPure :: (Member (Writer String) r, Member (State [String]) r) => Jail a -> Eff r a +adventPure :: [ Writer String, State [String] ] <:: r => Jail a -> Eff r a adventPure (Print a) = tell (a ++ "\n") adventPure Scan = do x <- get diff --git a/src/Control/Eff/Reader/Lazy.hs b/src/Control/Eff/Reader/Lazy.hs --- a/src/Control/Eff/Reader/Lazy.hs +++ b/src/Control/Eff/Reader/Lazy.hs @@ -7,8 +7,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeApplications #-} -- | Lazy read-only state module Control.Eff.Reader.Lazy ( Reader (..) + , withReader , ask , local , reader @@ -17,7 +19,6 @@ import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Monad.Base import Control.Monad.Trans.Control @@ -46,6 +47,13 @@ -- ^ In the latter case, when we make the request, we make it as Reader id. -- So, strictly speaking, GADTs are not really necessary. +-- | How to interpret a pure value in a reader context +withReader :: Monad m => a -> e -> m a +withReader x _ = return x +-- | Given a value to read, and a callback, how to respond to +-- requests. +instance Handle (Reader e) (e -> r) where + handle k Ask e = k e e -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction). @@ -54,10 +62,8 @@ -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. -runReader :: e -> Eff (Reader e ': r) w -> Eff r w -runReader e = handle_relay - return - (\Ask -> ($ e)) +runReader :: forall e r w. e -> Eff (Reader e ': r) w -> Eff r w +runReader e m = handle_relay withReader m e -- | Locally rebind the value in the dynamic environment This function is like a -- relay; it is both an admin for Reader requests, and a requestor of them. @@ -65,18 +71,15 @@ (e -> e) -> Eff r a -> Eff r a local f m = do e <- reader f - let - h :: Reader e t -> (t -> Eff r b) -> Eff r b - h Ask = ($ e) - interpose return h m + respond_relay' @(Reader e) withReader m e + -- or we could redefine handle and pass it to respond_relay -- | Request the environment value using a transformation function. reader :: (Member (Reader e) r) => (e -> a) -> Eff r a reader f = f `fmap` ask instance ( MonadBase m m - , SetMember Lift (Lift m) s - , MonadBaseControl m (Eff s) + , LiftedBase m s ) => MonadBaseControl m (Eff (Reader e ': s)) where type StM (Eff (Reader e ': s)) a = StM (Eff s) a liftBaseWith f = do e <- ask diff --git a/src/Control/Eff/Reader/Strict.hs b/src/Control/Eff/Reader/Strict.hs --- a/src/Control/Eff/Reader/Strict.hs +++ b/src/Control/Eff/Reader/Strict.hs @@ -7,18 +7,19 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE Safe #-} -- | Strict read-only state module Control.Eff.Reader.Strict ( Reader (..) - , ask - , local - , reader - , runReader - ) where + , withReader + , ask + , local + , reader + , runReader + ) where import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Monad.Base import Control.Monad.Trans.Control @@ -47,6 +48,13 @@ -- ^ In the latter case, when we make the request, we make it as Reader id. -- So, strictly speaking, GADTs are not really necessary. +-- | How to interpret a pure value in a reader context +withReader :: Monad m => a -> e -> m a +withReader x _ = return x +-- | Given a value to read, and a callback, how to respond to +-- requests. +instance Handle (Reader e) (e -> r) where + handle k Ask e = k e e -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction). @@ -56,28 +64,23 @@ -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. runReader :: e -> Eff (Reader e ': r) w -> Eff r w -runReader !e = handle_relay - return - (\Ask -> ($ e)) +runReader !e m = handle_relay withReader m e -- | Locally rebind the value in the dynamic environment This function is like a --- relay; it is both an admin for Reader requests, and a requestor of them +-- relay; it is both an admin for Reader requests, and a requestor of them. local :: forall e a r. Member (Reader e) r => (e -> e) -> Eff r a -> Eff r a local f m = do e <- reader f - let - h :: Reader e t -> (t -> Eff r b) -> Eff r b - h Ask = ($ e) - interpose return h m + respond_relay' @(Reader e) withReader m e + -- or we could redefine handle and pass it to respond_relay -- | Request the environment value using a transformation function. reader :: (Member (Reader e) r) => (e -> a) -> Eff r a reader f = f `fmap` ask instance ( MonadBase m m - , SetMember Lift (Lift m) s - , MonadBaseControl m (Eff s) + , LiftedBase m s ) => MonadBaseControl m (Eff (Reader e ': s)) where type StM (Eff (Reader e ': s)) a = StM (Eff s) a liftBaseWith f = do !e <- ask diff --git a/src/Control/Eff/State/Lazy.hs b/src/Control/Eff/State/Lazy.hs --- a/src/Control/Eff/State/Lazy.hs +++ b/src/Control/Eff/State/Lazy.hs @@ -8,12 +8,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} -- | Lazy state effect module Control.Eff.State.Lazy where import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy @@ -42,9 +42,20 @@ Get :: State s s Put :: s -> State s () +-- | Embed a pure value in a stateful computation, i.e., given an +-- initial state, how to interpret a pure value in a stateful +-- computation. +withState :: Monad m => a -> s -> m (a, s) +withState x s = return (x, s) + +-- | Handle 'State s' requests +instance Handle (State s) (s -> r) where + handle k sreq s = case sreq of + Get -> k s s + Put s' -> k () s' + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (State s ': r)) where type StM (Eff (State s ': r)) a = StM (Eff r) (a,s) liftBaseWith f = do s <- get @@ -81,11 +92,7 @@ -- | Run a state effect. compared to the @runState@ function, this is -- implemented naively and is expected to perform slower. runState' :: s -> Eff (State s ': r) a -> Eff r (a, s) -runState' s = - handle_relay_s s (\s0 x -> return (x,s0)) - (\s0 sreq k -> case sreq of - Get -> k s0 s0 - Put s1 -> k s1 ()) +runState' s m = handle_relay withState m s -- | Run a State effect. This variant is a bit optimized compared to -- @runState'@. @@ -93,10 +100,10 @@ -> Eff (State s ': r) a -- ^ Effect incorporating State -> Eff r (a, s) -- ^ Effect containing final state and a return value runState s (Val x) = return (x,s) -runState s (E u q) = case decomp u of +runState s (E q u) = case decomp u of Right Get -> runState s (q ^$ s) Right (Put s1) -> runState s1 (q ^$ ()) - Left u1 -> E u1 (singleK (\x -> runState s (q ^$ x))) + Left u1 -> E (singleK (\x -> runState s (q ^$ x))) u1 -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -113,29 +120,33 @@ -- | An encapsulated State handler, for transactional semantics -- The global state is updated only if the transactionState finished -- successfully -data TxState s = TxState -transactionState :: forall s r a. Member (State s) r => - TxState s -> Eff r a -> Eff r a -transactionState _ m = do s <- get; loop s m - where - loop :: s -> Eff r a -> Eff r a - loop s (Val x) = put s >> return x - loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of - Just Get -> loop s (q ^$ s) - Just (Put s') -> loop s'(q ^$ ()) - _ -> E u (qComps q (loop s)) +data TxState s v where + TxState :: TxState s s +type TxStateT s = TxState s s +-- | Embed Transactional semantics to a stateful computation. +withTxState :: Member (State s) r => a -> s -> Eff r a +withTxState x s = put s >> return x + +-- | Confer transactional semantics on a stateful computation. +transactionState :: forall s r a. Member (State s) r + => TxStateT s -> Eff r a -> Eff r a +transactionState _ m = do + s <- get + (respond_relay' @(State s) (withTxState @s)) m s + -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones. Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) -runStateR s m = loop s m +runStateR = loop where loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) - loop s0 (Val x) = return (x,s0) - loop s0 (E u q) = case decomp u of - Right (Tell w) -> k w () + loop s (Val x) = x `withState` s + loop s (E q u) = case decomp u of + Right (Tell w) -> handle k (Put w) s Left u1 -> case decomp u1 of - Right Ask -> k s0 s0 - Left u2 -> E u2 (singleK (k s0)) - where k x = qComp q (loop x) + Right Ask -> handle k Get s + Left u2 -> relay k u2 s + where k = connect loop q + connect nxt q = \s x -> qComp q (nxt x) s diff --git a/src/Control/Eff/State/OnDemand.hs b/src/Control/Eff/State/OnDemand.hs --- a/src/Control/Eff/State/OnDemand.hs +++ b/src/Control/Eff/State/OnDemand.hs @@ -13,10 +13,10 @@ import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy +import qualified Control.Eff.State.Lazy as S import Control.Monad.Base import Control.Monad.Trans.Control @@ -33,9 +33,15 @@ Put :: s -> OnDemandState s () Delay :: Eff '[OnDemandState s] a -> OnDemandState s a -- Eff as a transformer +-- | Given a continuation, respond to requests +instance Handle (OnDemandState s) (s -> r) where + handle k Get s = k s s + handle k (Put s) _ = k () s + handle k (Delay m) s = let ~(x, s') = run $ handle_relay S.withState m s + in k x s' + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (OnDemandState s ': r)) where type StM (Eff (OnDemandState s ': r)) a = StM (Eff r) (a,s) liftBaseWith f = do s <- get @@ -74,27 +80,20 @@ onDemand = send . Delay runState' :: s -> Eff (OnDemandState s ': r) w -> Eff r (w,s) -runState' s = - handle_relay_s s - (\s0 x -> return (x,s0)) - (\s0 sreq k -> case sreq of - Get -> k s0 s0 - Put s1 -> k s1 () - Delay m1 -> let ~(x,s1) = run $ runState' s0 m1 - in k s1 x) +runState' s m = handle_relay S.withState m s -- Since State is so frequently used, we optimize it a bit -- | Run a State effect runState :: s -- ^ Initial state -> Eff (OnDemandState s ': r) w -- ^ Effect incorporating State -> Eff r (w,s) -- ^ Effect containing final state and a return value -runState s (Val x) = return (x,s) -runState s0 (E u0 q) = case decomp u0 of +runState s (Val x) = S.withState x s +runState s0 (E q u0) = case decomp u0 of Right Get -> runState s0 (q ^$ s0) Right (Put s1) -> runState s1 (q ^$ ()) Right (Delay m1) -> let ~(x,s1) = run $ runState s0 m1 in runState s1 (q ^$ x) - Left u -> E u (singleK (\x -> runState s0 (q ^$ x))) + Left u -> E (singleK (\x -> runState s0 (q ^$ x))) u -- | Transform the state with a function. modify :: (Member (OnDemandState s) r) => (s -> s) -> Eff r () @@ -112,16 +111,13 @@ -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones. Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s) -runStateR s0 m0 = loop s0 m0 - where - loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s) - loop s (Val x) = return (x,s) - loop s (E u0 q) = case decomp u0 of - Right (Tell w) -> k w () - Left u -> case decomp u of - Right Ask -> k s s - Left u1 -> E u1 (singleK (k s)) - where k x = qComp q (loop x) +runStateR s (Val x) = S.withState x s +runStateR s (E q u) = case decomp u of + Right (Tell w) -> handle k (S.Put w) s + Left u1 -> case decomp u1 of + Right Ask -> handle k S.Get s + Left u2 -> relay k u2 s + where k s' x = qComp q (runStateR x) s' -- | Backwards state -- The overall state is represented with two attributes: the inherited @@ -136,7 +132,7 @@ where go :: s -> Eff '[OnDemandState s] a -> (a,s) go s (Val x) = (x,s) - go s0 (E u q) = case decomp u of + go s0 (E q u) = case decomp u of Right Get -> go s0 $ (q ^$ s0) Right (Put s1) -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1) Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ (q ^$ x) @@ -152,12 +148,13 @@ (x,head sp) where go :: ([s],[s]) -> Eff '[OnDemandState s] a -> Eff '[] (a,([s],[s])) - go ss = handle_relay_s ss (\ss0 x -> return (x,ss0)) - (\ss0@(sg,sp) req k -> case req of - Get -> k ss0 (head sg) - Put s1 -> k (tail sg,sp++[s1]) () - Delay m1 -> let ~(x,ss1) = run $ go ss0 m1 - in k ss1 x) + go s m' = handle_relay' S.withState + (\k req ss0@(sg,sp) -> case req of + Get -> k (head sg) ss0 + Put s1 -> k () (tail sg,sp++[s1]) + Delay m1 -> let ~(x,ss1) = run $ go ss0 m1 + in k x ss1) + m' s -- ^ A different notion of `backwards' is realized if we change the Put -- handler slightly. How? diff --git a/src/Control/Eff/State/Strict.hs b/src/Control/Eff/State/Strict.hs --- a/src/Control/Eff/State/Strict.hs +++ b/src/Control/Eff/State/Strict.hs @@ -9,12 +9,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} -- | Strict state effect module Control.Eff.State.Strict where import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Eff.Writer.Strict import Control.Eff.Reader.Strict @@ -43,9 +43,20 @@ Get :: State s s Put :: !s -> State s () +-- | Embed a pure value in a stateful computation, i.e., given an +-- initial state, how to interpret a pure value in a stateful +-- computation. +withState :: Monad m => a -> s -> m (a, s) +withState x s = return (x, s) + +-- | Handle 'State s' requests +instance Handle (State s) (s -> r) where + handle k sreq s = case sreq of + Get -> k s s + Put s' -> k () s' + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (State s ': r)) where type StM (Eff (State s ': r)) a = StM (Eff r) (a,s) liftBaseWith f = do s <- get @@ -80,23 +91,19 @@ -- inline get/put, even if I put the INLINE directives and play with phases. -- (Inlining works if I use 'inline' explicitly). -runState' :: s -> Eff (State s ': r) a -> Eff r (a, s) -runState' !s = - handle_relay_s s (\s0 x -> return (x,s0)) - (\s0 sreq k -> case sreq of - Get -> k s0 s0 - Put s1 -> k s1 ()) +runState' :: forall s r a. s -> Eff (State s ': r) a -> Eff r (a, s) +runState' !s m = handle_relay withState m s -- Since State is so frequently used, we optimize it a bit -- | Run a State effect -runState :: s -- ^ Effect incorporating State - -> Eff (State s ': r) a -- ^ Initial state +runState :: s -- ^ Initial state + -> Eff (State s ': r) a -- ^ Effect incorporating State -> Eff r (a, s) -- ^ Effect containing final state and a return value -runState !s (Val x) = return (x,s) -runState !s (E u q) = case decomp u of +runState !s (Val x) = withState x s +runState !s (E q u) = case decomp u of Right Get -> runState s (q ^$ s) Right (Put s1) -> runState s1 (q ^$ ()) - Left u1 -> E u1 (singleK (\x -> runState s (q ^$ x))) + Left u1 -> E (qComps q (runState s)) u1 -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -116,17 +123,18 @@ -- The global state is updated only if the transactionState finished -- successfully data TxState s = TxState -transactionState :: forall s r a. Member (State s) r => - TxState s -> Eff r a -> Eff r a -transactionState _ m = do s <- get; loop s m - where - loop :: s -> Eff r a -> Eff r a - loop s (Val x) = put s >> return x - loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of - Just Get -> loop s (q ^$ s) - Just (Put s') -> loop s'(q ^$ ()) - _ -> E u (qComps q (loop s)) +-- | Embed Transactional semantics to a stateful computation. +withTxState :: Member (State s) r => a -> s -> Eff r a +withTxState x s = put s >> return x + +-- | Confer transactional semantics on a stateful computation. +transactionState :: forall s r a. Member (State s) r + => TxState s -> Eff r a -> Eff r a +transactionState _ m = do + s <- get + (respond_relay' @(State s) (withTxState @s)) m s + -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones. Thus we define a handler for two effects together. @@ -134,10 +142,10 @@ runStateR !s m = loop s m where loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) - loop s0 (Val x) = return (x,s0) - loop s0 (E u q) = case decomp u of - Right (Tell w) -> k w () + loop s0 (Val x) = x `withState` s0 + loop s0 (E q u) = case decomp u of + Right (Tell w) -> handle k (Put w) s0 Left u1 -> case decomp u1 of - Right Ask -> k s0 s0 - Left u2 -> E u2 (singleK (k s0)) - where k x = qComp q (loop x) + Right Ask -> handle k Get s0 + Left u2 -> relay k u2 s0 + where k s' x = qComp q (loop x) s' diff --git a/src/Control/Eff/Trace.hs b/src/Control/Eff/Trace.hs --- a/src/Control/Eff/Trace.hs +++ b/src/Control/Eff/Trace.hs @@ -5,17 +5,27 @@ {-# LANGUAGE Safe #-} -- | A Trace effect for debugging module Control.Eff.Trace( Trace (..) + , withTrace , trace , runTrace ) where import Control.Eff import Control.Eff.Extend +import Data.Function (fix) -- | Trace effect for debugging data Trace v where Trace :: String -> Trace () +-- | Embed a pure value in Trace context +withTrace :: a -> IO a +withTrace = return + +-- | Given a callback and request, respond to it +instance Handle Trace (IO k) where + handle k (Trace s) = putStrLn s >> k () + -- | Print a string as a trace. trace :: Member Trace r => String -> Eff r () trace = send . Trace @@ -23,8 +33,8 @@ -- | Run a computation producing Traces. -- The handler for IO request: a terminal handler runTrace :: Eff '[Trace] w -> IO w -runTrace (Val x) = return x -runTrace (E u q) = case decomp u of - Right (Trace s) -> putStrLn s >> runTrace (q ^$ ()) - -- Nothing more can occur - Left _ -> error "runTrace: the impossible happened!: Union []" +runTrace = fix step where + step next = eff return + (impureDecomp + (handle `andThen` next) + (\_ _ -> error "Impossible: Nothing to relay!")) diff --git a/src/Control/Eff/Writer/Lazy.hs b/src/Control/Eff/Writer/Lazy.hs --- a/src/Control/Eff/Writer/Lazy.hs +++ b/src/Control/Eff/Writer/Lazy.hs @@ -8,8 +8,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} -- | Lazy write-only state module Control.Eff.Writer.Lazy ( Writer(..) + , withWriter , tell , censor , runWriter @@ -26,7 +28,6 @@ import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Applicative ((<|>)) @@ -46,9 +47,18 @@ data Writer w v where Tell :: w -> Writer w () +-- | How to interpret a pure value in a writer context, given the +-- value for mempty. +withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b) +withWriter x empty _append = return (x, empty) +-- | Given a value to write, and a callback (which includes empty and +-- append), respond to requests. +instance Monad m => Handle (Writer w) (b -> (w -> b -> b) -> m (a, b)) where + handle k (Tell w) e append = k () e append >>= + \(x, l) -> return (x, w `append` l) + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (Writer w ': r)) where type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w]) liftBaseWith f = raise $ liftBaseWith $ \runInBase -> @@ -63,22 +73,16 @@ -- | Transform the state being produced. censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a -censor f = interpose return h +censor f = respond_relay return h where - h :: Writer w t -> (t -> Eff r b) -> Eff r b - h (Tell w) k = tell (f w) >>= k + h :: (v -> Eff r b) -> Writer w v -> Eff r b + h k (Tell w) = tell (f w) >>= k -- | Handle Writer requests, using a user-provided function to accumulate -- values, hence no Monoid constraints. runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) -runWriter accum b = handle_relay - (\x -> return (x, b)) - (\(Tell w) k -> k () >>= \(x, l) -> return (x, w `accum` l)) - -- the second arg to 'handle_relay' above is same as: - -- (\(Tell w) k -> second (accum w) `fmap` k ()) - -- where - -- second f (x, y) = (x, f y) +runWriter accum b m = handle_relay withWriter m b accum -- | Handle Writer requests, using a List to accumulate values. runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w]) diff --git a/src/Control/Eff/Writer/Strict.hs b/src/Control/Eff/Writer/Strict.hs --- a/src/Control/Eff/Writer/Strict.hs +++ b/src/Control/Eff/Writer/Strict.hs @@ -11,6 +11,7 @@ {-# LANGUAGE CPP #-} -- | Strict write-only state module Control.Eff.Writer.Strict ( Writer(..) + , withWriter , tell , censor , runWriter @@ -27,7 +28,6 @@ import Control.Eff import Control.Eff.Extend -import Control.Eff.Lift import Control.Applicative ((<|>)) @@ -47,9 +47,18 @@ data Writer w v where Tell :: !w -> Writer w () +-- | How to interpret a pure value in a writer context, given the +-- value for mempty. +withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b) +withWriter x empty _append = return (x, empty) +-- | Given a value to write, and a callback (which includes empty and +-- append), respond to requests. +instance Monad m => Handle (Writer w) (b -> (w -> b -> b) -> m (a, b)) where + handle k (Tell w) e append = k () e append >>= + \(x, l) -> return (x, w `append` l) + instance ( MonadBase m m - , SetMember Lift (Lift m) r - , MonadBaseControl m (Eff r) + , LiftedBase m r ) => MonadBaseControl m (Eff (Writer w ': r)) where type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w]) liftBaseWith f = raise $ liftBaseWith $ \runInBase -> @@ -64,22 +73,16 @@ -- | Transform the state being produced. censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a -censor f = interpose return h +censor f = respond_relay return h where - h :: Writer w t -> (t -> Eff r b) -> Eff r b - h (Tell w) k = tell (f w) >>= k + h :: (v -> Eff r b) -> Writer w v -> Eff r b + h k (Tell w) = tell (f w) >>= k -- | Handle Writer requests, using a user-provided function to accumulate -- values, hence no Monoid constraints. runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) -runWriter accum !b = handle_relay - (\x -> return (x, b)) - (\(Tell w) k -> k () >>= \(x, l) -> return (x, w `accum` l)) - -- the second arg to 'handle_relay' above is same as: - -- (\(Tell w) k -> second (accum w) `fmap` k ()) - -- where - -- second f (x, y) = (x, f y) +runWriter accum !b m = handle_relay withWriter m b accum -- | Handle Writer requests, using a List to accumulate values. runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w]) diff --git a/src/Data/OpenUnion.hs b/src/Data/OpenUnion.hs --- a/src/Data/OpenUnion.hs +++ b/src/Data/OpenUnion.hs @@ -1,8 +1,6 @@ {-# OPTIONS_HADDOCK show-extensions #-} {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP #-} - {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,10 +13,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51 -{-# LANGUAGE OverlappingInstances #-} -#endif - -- Only for SetMember below, when emulating Monad Transformers {-# LANGUAGE FunctionalDependencies, UndecidableInstances #-} @@ -67,12 +61,8 @@ import Unsafe.Coerce(unsafeCoerce) -#if __GLASGOW_HASKELL__ > 800 import Data.Kind (Constraint) import GHC.TypeLits -#else -import GHC.Exts (Constraint) -#endif -- | The data constructors of Union are not exported -- @@ -103,21 +93,6 @@ inj :: t v -> Union r v prj :: Union r v -> Maybe (t v) -#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51 -{- --- Optimized specialized instance -instance Member t '[t] where - {-# INLINE inj #-} - {-# INLINE prj #-} - inj x = Union 0 x - prj (Union _ x) = Just (unsafeCoerce x) --} -instance (FindElem t r) => Member t r where - {-# INLINE inj #-} - {-# INLINE prj #-} - inj = inj' (unP $ (elemNo :: P t r)) - prj = prj' (unP $ (elemNo :: P t r)) -#else -- | Explicit type-level equality condition is a dirty -- hack to eliminate the type annotation in the trivial case, -- such as @run (runReader () get)@. @@ -142,7 +117,6 @@ {-# INLINE prj #-} inj = inj' (unP $ (elemNo :: P t r)) prj = prj' (unP $ (elemNo :: P t r)) -#endif -- | A useful operator for reducing boilerplate in signatures. -- @@ -181,29 +155,19 @@ instance FindElem t (t ': r) where elemNo = P 0 -#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51 -instance FindElem t r => FindElem t (t' ': r) where -#else instance {-# OVERLAPPABLE #-} FindElem t r => FindElem t (t' ': r) where -#endif elemNo = P $ 1 + (unP $ (elemNo :: P t r)) -#if __GLASGOW_HASKELL__ > 800 instance TypeError ('Text "Cannot unify effect types." ':$$: 'Text "Unhandled effect: " ':<>: 'ShowType t ':$$: 'Text "Perhaps check the type of effectful computation and the sequence of handlers for concordance?") => FindElem t '[] where elemNo = error "unreachable" -#endif -- | Using overlapping instances here is OK since this class is private to this -- module class EQU (a :: k) (b :: k) p | a b -> p instance EQU a a 'True -#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51 -instance (p ~ 'False) => EQU a b p -#else instance {-# OVERLAPPABLE #-} (p ~ 'False) => EQU a b p -#endif -- | This class is used for emulating monad transformers class Member t r => SetMember (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t diff --git a/test/Control/Eff/Choose/Test.hs b/test/Control/Eff/Choose/Test.hs --- a/test/Control/Eff/Choose/Test.hs +++ b/test/Control/Eff/Choose/Test.hs @@ -8,7 +8,6 @@ import Control.Eff.Example import Control.Eff.Example.Test (ex2) import Control.Eff.Exception -import Control.Eff.Lift import Control.Eff.Choose import Utils @@ -41,14 +40,17 @@ let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1])) exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1])) exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1])) + exRec_4 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,11,1])) in assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1 >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2 - >> assertEqual "Choose: error recovery: exRec_1" expected3 exRec_3 + >> assertEqual "Choose: error recovery: exRec_3" expected3 exRec_3 + >> assertEqual "Choose: error recovery: exRec_4" expected4 exRec_4 where expected1 = Right [5,7,1] expected2 = [Right 5,Right 7,Right 1] expected3 = Left (TooBig 11) + expected4 = [Right 5,Right 7,Left (TooBig 11),Right 1] -- Errror recovery part -- The code is the same as in transf1.hs. The inferred signatures differ -- Was: exRec :: MonadError TooBig m => m Int -> m Int diff --git a/test/Control/Eff/Coroutine/Test.hs b/test/Control/Eff/Coroutine/Test.hs --- a/test/Control/Eff/Coroutine/Test.hs +++ b/test/Control/Eff/Coroutine/Test.hs @@ -32,7 +32,7 @@ th1 = yieldInt 1 >> yieldInt 2 c1 = runTrace (loop =<< runC th1) - where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop + where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop loop (Done) = trace ("Done") case_Coroutines_c2 :: Assertion @@ -54,12 +54,12 @@ -- Code is essentially the same as in transf.hs; no liftIO though c2 = runTrace $ runReader (10::Int) (loop =<< runC th2) - where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop + where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop loop Done = trace "Done" -- locally changing the dynamic environment for the suspension c21 = runTrace $ runReader (10::Int) (loop =<< runC th2) - where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop + where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop loop Done = trace "Done" case_Coroutines_c3 :: Assertion @@ -80,20 +80,20 @@ where ay = ask >>= yieldInt c3 = runTrace $ runReader (10::Int) (loop =<< runC th3) - where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop + where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop loop Done = trace "Done" -- The desired result: the coroutine shares the dynamic environment with its -- parent; however, when the environment is locally rebound, it becomes -- private to coroutine. c31 = runTrace $ runReader (10::Int) (loop =<< runC th3) - where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop + where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop loop Done = trace "Done" -- We now make explicit that the client computation, run by th4, -- is abstract. We abstract it out of th4 c4 = runTrace $ runReader (10::Int) (loop =<< runC (th4 client)) - where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop + where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop loop Done = trace "Done" -- cl, client, ay are monomorphic bindings @@ -122,7 +122,7 @@ expected actual where c5 = runTrace $ runReader (10::Int) (loop =<< runC (th client)) - where loop (Y x k) = trace (show (x::Int)) >> local (\_y->x+1) (k ()) >>= loop + where loop (Y k x) = trace (show (x::Int)) >> local (\_y->x+1) (k ()) >>= loop loop Done = trace "Done" -- cl, client, ay are monomorphic bindings @@ -164,7 +164,7 @@ where c7 = runTrace $ runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client))) - where loop (Y x k) = trace (show (x::Int)) >> + where loop (Y k x) = trace (show (x::Int)) >> local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop loop Done = trace "Done" @@ -208,7 +208,7 @@ where c7' = runTrace $ runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client))) - where loop (Y x k) = trace (show (x::Int)) >> + where loop (Y k x) = trace (show (x::Int)) >> local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop loop Done = trace "Done" diff --git a/test/Control/Eff/Exception/Test.hs b/test/Control/Eff/Exception/Test.hs --- a/test/Control/Eff/Exception/Test.hs +++ b/test/Control/Eff/Exception/Test.hs @@ -9,7 +9,6 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception -import Control.Eff.Lift import Control.Eff.Writer.Strict #if __GLASGOW_HASKELL__ < 710 import Data.Monoid diff --git a/test/Control/Eff/Fresh/Test.hs b/test/Control/Eff/Fresh/Test.hs --- a/test/Control/Eff/Fresh/Test.hs +++ b/test/Control/Eff/Fresh/Test.hs @@ -6,8 +6,8 @@ module Control.Eff.Fresh.Test (testGroups) where import Test.HUnit hiding (State) +import Control.Eff import Control.Eff.Fresh -import Control.Eff.Lift import Control.Eff.Trace import Utils @@ -22,13 +22,13 @@ assertEqual "Fresh: test" (unlines ["Fresh 0", "Fresh 1"]) actual where - tfresh' = runTrace $ flip runFresh' 0 $ do + tfresh' = runTrace $ runFresh' 0 $ do n <- fresh trace $ "Fresh " ++ show n n <- fresh trace $ "Fresh " ++ show n case_Fresh_monadBaseControl :: Assertion -case_Fresh_monadBaseControl = runLift (runFresh' (doThing $ fresh >> fresh) i) @=? Just (i + 1) +case_Fresh_monadBaseControl = runLift (runFresh' i (doThing $ fresh >> fresh)) @=? Just (i + 1) where i = 0 diff --git a/test/Control/Eff/Lift/Test.hs b/test/Control/Eff/Lift/Test.hs deleted file mode 100644 --- a/test/Control/Eff/Lift/Test.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, NoMonomorphismRestriction #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} - -module Control.Eff.Lift.Test (testGroups) where - -import Test.HUnit hiding (State) -import Control.Eff -import Control.Eff.Exception -import Control.Eff.Lift -import Control.Eff.Reader.Strict -import Control.Eff.State.Strict -import qualified Control.Exception as Exc -import Data.Typeable -import Utils - -import Test.Framework.TH -import Test.Framework.Providers.HUnit - -testGroups = [ $(testGroupGenerator) ] - --- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved. -case_Lift_building :: Assertion -case_Lift_building = runLift possiblyAmbiguous - where - possiblyAmbiguous :: (Monad m, SetMember Lift (Lift m) r) => Eff r () - possiblyAmbiguous = lift $ return () - -case_Lift_tl1r :: Assertion -case_Lift_tl1r = do - ((), output) <- catchOutput tl1r - assertEqual "Test tl1r" (showLn input) output - where - input = (5::Int) - -- tl1r :: IO () - tl1r = runLift (runReader input tl1) - where - tl1 = ask >>= \(x::Int) -> lift . print $ x - -case_Lift_tMd' :: Assertion -case_Lift_tMd' = do - actual <- catchOutput tMd' - let expected = (output, (showLines input)) - assertEqual "Test mapMdebug using Lift" expected actual - where - input = [1..5] - val = (10::Int) - output = map (+ val) input - - tMd' = runLift $ runReader val $ mapMdebug' f input - where f x = ask `add` return x - - -- Re-implemenation of mapMdebug using Lifting - -- The signature is inferred - mapMdebug' :: (Show a, SetMember Lift (Lift IO) r) => - (a -> Eff r b) -> [a] -> Eff r [b] - mapMdebug' _f [] = return [] - mapMdebug' f (h:t) = do - lift $ print h - h' <- f h - t' <- mapMdebug' f t - return (h':t') - --- tests from -data MyException = MyException String deriving (Show, Typeable) -instance Exc.Exception MyException - -exfn True = lift . Exc.throw $ (MyException "thrown") -exfn False = return True - -testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s) - -case_catchDynE_test1 :: Assertion -case_catchDynE_test1 = do - ((), actual) <- catchOutput test1 - let expected = unlines [ "(\"thrown\",[\"begin\"])" - , "(\"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test1: exception shouldn't drop Writer's state" - expected actual - where - -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- - -- that is, an exception will drop the Writer's state, even if that - -- exception is caught. Here, the state is preserved! - -- So, this is an advantage over MTL! - test1 = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ testc m - m = do - modify ("begin":) - x <- ask - r <- exfn x - modify ("end":) - return r - --- Let us use an Error effect instead -case_catchDynE_test1' :: Assertion -case_catchDynE_test1' = do - ((), actual') <- catchOutput test1' - let expected' = unlines [ "(Left \"thrown\",[\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test1': Error shouldn't drop Writer's state" - expected' actual' - where - -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- - -- that is, an exception will drop the Writer's state, even if that - -- exception is caught. Here, the state is preserved! - -- So, this is an advantage over MTL! - test1' = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - m = do - modify ("begin":) - x <- ask - r <- exfn x - modify ("end":) - return r - - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id - exfn True = throwError $ ("thrown") - exfn False = return True - --- Now, the behavior of the dynamic Exception and Error effect is consistent. --- The state is preserved. Before it wasn't. -case_catchDynE_test2 :: Assertion -case_catchDynE_test2 = do - ((), actual) <- catchOutput test2 - let expected = unlines [ "(Left \"thrown\",[\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test2: Error shouldn't drop Writer's state" - expected actual - where - test2 = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id - m = do - modify ("begin":) - x <- ask - r <- exfn x `catchDynE` (\ (MyException s) -> throwError s) - modify ("end":) - return r - --- Full recovery -case_catchDynE_test2' :: Assertion -case_catchDynE_test2' = do - ((), actual) <- catchOutput test2' - let expected = unlines [ "(Right \"False\",[\"end\",\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test2': Fully recover from errors" - expected actual - where - test2' = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id - m = do - modify ("begin":) - x <- ask - r <- exfn x `catchDynE` (\ (MyException _s) -> return False) - modify ("end":) - return r - --- Throwing within a handler -case_catchDynE_test3 :: Assertion -case_catchDynE_test3 = do - ((), actual) <- catchOutput test3 - let expected = unlines [ "(Right \"rethrow:thrown\",[\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test3: Throwing within a handler" - expected actual - where - test3 = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id - m = do - modify ("begin":) - x <- ask - r <- exfn x `catchDynE` (\ (MyException s) -> - lift . Exc.throw . MyException $ - ("rethrow:" ++ s)) - modify ("end":) - return r - --- Implement the transactional behavior: when the exception is raised, --- the state is rolled back to what it existed at the entrance to --- the catch block. --- This is the ``scoping behavior'' of `Handlers in action' -case_catchDynE_tran :: Assertion -case_catchDynE_tran = do - ((), actual) <- catchOutput tran - let expected = unlines ["(\"thrown\",[\"init\"])" - ,"(\"True\",[\"end\",\"begin\",\"init\"])"] - assertEqual "catchDynE: tran: Transactional behaviour" - expected actual - where - tran = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x :: Bool) . runState ([]::[String]) $ m1 - m1 = do - modify ("init":) - testc (transactionState (TxState :: TxState [String]) m) - m = do - modify ("begin":) - x <- ask - r <- exfn x - modify ("end":) - return r -{- -- without transaction -("thrown",["begin","init"]) -("True",["end","begin","init"]) --} - --- With transaction -{- -("thrown",["init"]) -("True",["end","begin","init"]) --} diff --git a/test/Control/Eff/NdetEff/Bench.hs b/test/Control/Eff/NdetEff/Bench.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/NdetEff/Bench.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} + +-- A benchmark of shift/reset: Filinski's representing non-determinism monads +-- +-- The benchmark is taken from Sec 6.1 of +-- Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct +-- Implementation of Shift and Reset, ICFP'02, pp. 271-282. +-- http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf +-- This code is a straightforward translation of bench_nondet.ml +-- +-- This is a micro-benchmark: it is very non-determinism-intensive. It is +-- *not* representative: the benchmark does nothing else but +-- concatenates lists. The List monad does this directly; whereas +-- continuation monads do the concatenation with more overhead (e.g., +-- building the closures representing continuations). Therefore, +-- the List monad here outperforms all other implementations of +-- non-determinism. +-- It should be stressed that the delimited control is optimized +-- for the case where control operations are infrequent, so we pay +-- as we go. The use of the delimited control operators is more +-- expensive, but the code that does not use delimited control does not +-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that +-- does not use non-determinism, so the overhead of delimited control +-- is very noticeable. That is why this benchmark is good at estimating +-- the overhead of different implementations of delimited control. + +-- To compile this code +-- ghc -O2 -rtsopts -main-is Bench_nondet.main_list5 Bench_nondet.hs +-- To run this code +-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet + +module Control.Eff.NdetEff.Bench where + +import Control.Eff +import qualified Control.Eff.NdetEff as E + +import Data.List (sort) +-- import Control.Monad.Identity +-- import Control.Monad (liftM2) +import Control.Monad (MonadPlus(..), msum) +import Control.Applicative +-- import System.CPUTime + +-- Small language with non-determinism: just like the one in our DSL-WC paper + +int :: MonadPlus repr => Int -> repr Int +int x = return x + +add :: MonadPlus repr => repr Int -> repr Int -> repr Int +-- add xs ys = liftM2 (+) xs ys +add xs ys = do {x <- xs; y <- ys; return $! x+y } + +lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b) +lam f = return $ f . return + +app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b) +app xs ys = do {x <- xs; y <- ys; x y} + +amb :: MonadPlus repr => [repr Int] -> repr Int +amb = msum + +-- Benchmark cases + +test_ww :: MonadPlus repr => repr Int +test_ww = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32] + +ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13, + 12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15, + 14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15, + 16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, + 14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12, + 11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36, + 38, 39, 38, 35, 42, 44, 45, 44, 41] + +-- Real benchmark cases + +test_www :: MonadPlus repr => repr Int +test_www = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]) + +test_wwww :: MonadPlus repr => repr Int +test_wwww = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])) + +test_w5 :: MonadPlus repr => repr Int +test_w5 = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` + (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))) + + +-- Different implementations of our language (MonadPlus) + +-- The List monad: Non-determinism monad as a list of successes + +run_list :: [Int] -> [Int] +run_list = id + +testl1 = (==) [101, 201, 102, 202] . run_list $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testl2 = ww_answer == sort (run_list test_ww) + + +-- CPS-monad, implemented by hand; it must be quite efficient therefore +-- It is a monad, not a transformer. It cannot do any other effects beside +-- the non-determinism. +newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]} + +instance Functor CPS where + fmap f fa = CPS $ \k -> unCPS fa (k . f) +instance Applicative CPS where + pure x = CPS $ \k -> k x + mf <*> fa = CPS $ \k -> unCPS mf (\f -> unCPS fa (k . f)) +instance Monad CPS where + return x = CPS $ \k -> k x + m >>= f = CPS $ \k -> unCPS m (\a -> unCPS (f a) k) + +instance Alternative CPS where + empty = mzero + (<|>) = mplus +instance MonadPlus CPS where + mzero = CPS $ \_ -> [] + mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k + +run_cps :: CPS Int -> [Int] +run_cps m = unCPS m (\x -> [x]) + + +testc1 = (==) [101, 201, 102, 202] . run_cps $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testc2 = ww_answer == sort (run_cps test_ww) + +-- ExtEff implementation +-- Eff is already an instance of MonadPlus. Thus we only need to +-- define the run instance + +-- run_eff :: Eff '[E.Choose] Int -> [Int] +-- run_eff = run . E.makeChoice + +-- More direct interpreter +-- makeChoiceA :: Eff (E.NdetEff ': r) a -> Eff r [a] +-- makeChoiceA = handle_relay (\x -> x `seq` return [x] ) $ \m k -> case m of +-- E.MZero -> return [] +-- E.MPlus -> liftM2 (++) (k True) (k False) + +run_eff :: Eff '[E.NdetEff] Int -> [Int] +run_eff = run . E.makeChoiceA + +teste2 = ww_answer == sort (run_eff test_ww) + + +data Count a = Count (Maybe a) !Int +instance Functor Count where + fmap f (Count (Just x) n) = Count (Just (f x)) n + fmap _ _ = Count Nothing 0 + +instance Applicative Count where + pure x = Count (Just x) 1 + Count (Just f) nf <*> Count (Just x) nx = Count (Just (f x)) (nf + nx) + _ <*> _ = Count Nothing 0 + +instance Alternative Count where + empty = Count Nothing 0 + Count m1@Just{} n1 <|> Count _ n2 = Count m1 (n1+n2) + _ <|> m2 = m2 + +run_effc :: Eff '[E.NdetEff] Int -> Int +run_effc m = let Count _ n = run . E.makeChoiceA $ m in n + + +teste12 = length ww_answer == run_effc test_ww + +{- +-- CCEx monad +-- Not a very optimal implementation of mplus (a tree would be better) +-- But is suffices as a benchmark of different implementations of CC +instance Monad m => MonadPlus (CC (PS [Int]) m) where + mzero = abortP ps (return []) + mplus m1 m2 = takeSubCont ps (\k -> + liftM2 (++) + (pushPrompt ps (pushSubCont k m1)) + (pushPrompt ps (pushSubCont k m2))) + +run_dir :: CC (PS [Int]) Identity Int -> [Int] +run_dir m = runIdentity . runCC $ + pushPrompt ps (m >>= return . (:[])) + + +testd1 = (==) [101, 201, 102, 202] . run_dir $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testd2 = ww_answer == sort (run_dir test_ww) + +-} + + +-- Benchmarks themselves + +main_list3 = print $ 2400 == (length . run_list $ test_www) +main_list4 = print $ 48000 == (length . run_list $ test_wwww) +main_list5 = print $ 960000 == (length . run_list $ test_w5) + +main_cps3 = print $ 2400 == (length . run_cps $ test_www) +main_cps4 = print $ 48000 == (length . run_cps $ test_wwww) +main_cps5 = print $ 960000 == (length . run_cps $ test_w5) + +-- We expect the direct implementation to be slower since CC is the transformer, +-- whereas CPS is not. The latter is hand-written for a specific answer-type. +main_eff3 = print $ 2400 == (length . run_eff $ test_www) +main_eff4 = print $ 48000 == (length . run_eff $ test_wwww) +main_eff5 = print $ 960000 == (length . run_eff $ test_w5) + +main_eff5c = print $ 960000 == (run_effc $ test_w5) + +-- To clarify the effect of building a list +main_eff5m = print $ ((run . E.makeChoiceA $ test_w5) :: Maybe Int) + +{- +-- Instantiate CC to the IO as the base monad, attempting to quantify the +-- effect of the Identity transformer +main_dir5io = do + l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[])) + print $ length l == 960000 +-} + +-- ------------------------------------------------------------------------ +-- Old results, from 2010 + +{- Median of 5 runs + +main_list5 +<> + 0.30 real 0.30 user 0.00 sys + +main_cps5 +<> + 0.60 real 0.58 user 0.01 sys + +main_dir5 (CCExc implementation) +<> + 4.48 real 4.22 user 0.24 sys + +main_dir5io (CCExc implementation) +<> + 5.45 real 5.18 user 0.21 sys + + +main_dir5 (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.70 real 4.44 user 0.23 sys + +main_dir5io (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.72 real 4.44 user 0.23 sys + +main_ref5io (without pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 68.94 real 67.51 user 1.03 sys + + +main_ref5io (with pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 20.50 real 19.92 user 0.46 sys + +-} + +-- ------------------------------------------------------------------------ +-- Newer Benchmarks, July 2015 + +{- +main_list5 +True +<> + +main_cps5 +True +<> + +-- using makeChoiceA (setting f as an Alternative) +main_eff5 +True +<> + +With strict add: +True +<> +1.32user 0.08system 0:01.40elapsed 99%CPU (0avgtext+0avgdata 819408maxresident)k +0inputs+0outputs (0major+51485minor)pagefaults 0swaps + +It looks like a huge memory leak. Perhaps the list is fully realized? + + +Using the counting Alternative Count +True +<> + +Using Maybe +Just 32 +<> +0.67user 0.05system 0:00.72elapsed 100%CPU (0avgtext+0avgdata 620752maxresident)k +0inputs+0outputs (0major+38937minor)pagefaults 0swaps + +-- using Maybe, but with the better makeChoice +Just 32 +<> +0.63user 0.04system 0:00.68elapsed 100%CPU (0avgtext+0avgdata 570720maxresident)k +0inputs+0outputs (0major+35760minor)pagefaults 0swaps + +Better makeChoiceA, full list +True +<> +0.42user 0.02system 0:00.44elapsed 100%CPU (0avgtext+0avgdata 244064maxresident)k +0inputs+0outputs (0major+15391minor)pagefaults 0swaps + +-} diff --git a/test/Control/Eff/NdetEff/Test.hs b/test/Control/Eff/NdetEff/Test.hs --- a/test/Control/Eff/NdetEff/Test.hs +++ b/test/Control/Eff/NdetEff/Test.hs @@ -2,12 +2,11 @@ {-# LANGUAGE TypeOperators, DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -module Control.Eff.NdetEff.Test (testGroups) where +module Control.Eff.NdetEff.Test (testGroups, gen_testCA, gen_ifte_test) where import Test.HUnit hiding (State) import Control.Applicative import Control.Eff -import Control.Eff.Lift import Control.Eff.NdetEff import Control.Eff.Writer.Strict import Control.Monad (msum, guard, mzero, mplus) @@ -18,15 +17,33 @@ testGroups = [ $(testGroupGenerator) ] +-- TODO: add quickcheck test to test conformance of different +-- implementations of 'makeChoiceA' and 'msplit'. + +-- TODO: add benchmarks for different implementations of 'makeChoiceA' +-- and 'msplit'. + +gen_testCA :: (Integral a) => a -> Eff (NdetEff ': r) a +gen_testCA x = do + i <- msum . fmap return $ [1..x] + guard (i `mod` 2 == 0) + return i + case_NdetEff_testCA :: Assertion -case_NdetEff_testCA = [2, 4..10] @=? (run $ makeChoiceA testCA) - where - testCA :: (Integral a) => Eff (NdetEff ': r) a - testCA = do - i <- msum . fmap return $ [1..10] - guard (i `mod` 2 == 0) - return i +case_NdetEff_testCA = [2, 4..10] @=? (run $ makeChoiceA (gen_testCA 10)) +gen_ifte_test x = do + n <- gen x + ifte (do + d <- gen x + guard $ d < n && n `mod` d == 0 + -- _ <- trace ("d: " ++ show d) (return ()) + ) + (\_ -> mzero) + (return n) + where gen x = msum . fmap return $ [2..x] + + case_NdetEff_ifte :: Assertion case_NdetEff_ifte = let primes = ifte_test_run @@ -34,28 +51,17 @@ assertEqual "NdetEff: test ifte using primes" [2,3,5,7,11,13,17,19,23,29] primes where - ifte_test = do - n <- gen - ifte (do - d <- gen - guard $ d < n && n `mod` d == 0 - -- _ <- trace ("d: " ++ show d) (return ()) - ) - (\_ -> mzero) - (return n) - where gen = msum . fmap return $ [2..30] - ifte_test_run :: [Int] - ifte_test_run = run . makeChoiceA $ ifte_test + ifte_test_run = run . makeChoiceA $ (gen_ifte_test 30) -- called reflect in the LogicT paper case_NdetEff_reflect :: Assertion case_NdetEff_reflect = let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit - tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= unmsplit) + tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= reflect) tsplitr20 = run $ makeChoiceA $ runListWriter tsplit - tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= unmsplit) + tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= reflect) in assertEqual "tsplitr10" expected1 tsplitr10 >> assertEqual "tsplitr11" expected1 tsplitr11 @@ -65,10 +71,6 @@ expected1 = ([1, 2],["begin", "end"]) expected2 = [(1, ["begin"]), (2, ["end"])] expected21 = [(1, ["begin"]), (2, ["begin", "end"])] - - unmsplit :: Member NdetEff r => (Maybe (a, Eff r a)) -> Eff r a - unmsplit Nothing = mzero - unmsplit (Just (a,m)) = return a `mplus` m tsplit = (tell "begin" >> return 1) `mplus` diff --git a/test/Control/Eff/Reader/Lazy/Test.hs b/test/Control/Eff/Reader/Lazy/Test.hs --- a/test/Control/Eff/Reader/Lazy/Test.hs +++ b/test/Control/Eff/Reader/Lazy/Test.hs @@ -8,7 +8,6 @@ import Test.HUnit hiding (State) import Control.Eff -import Control.Eff.Lift import Control.Eff.Reader.Lazy import Control.Monad import Utils diff --git a/test/Control/Eff/Reader/Strict/Test.hs b/test/Control/Eff/Reader/Strict/Test.hs --- a/test/Control/Eff/Reader/Strict/Test.hs +++ b/test/Control/Eff/Reader/Strict/Test.hs @@ -7,7 +7,6 @@ import Test.HUnit hiding (State) import Control.Eff -import Control.Eff.Lift import Control.Eff.Reader.Strict import Utils diff --git a/test/Control/Eff/State/Lazy/Test.hs b/test/Control/Eff/State/Lazy/Test.hs --- a/test/Control/Eff/State/Lazy/Test.hs +++ b/test/Control/Eff/State/Lazy/Test.hs @@ -7,7 +7,6 @@ import Test.HUnit hiding (State) import Control.Eff -import Control.Eff.Lift import Control.Eff.State.Lazy import Utils diff --git a/test/Control/Eff/State/OnDemand/Test.hs b/test/Control/Eff/State/OnDemand/Test.hs --- a/test/Control/Eff/State/OnDemand/Test.hs +++ b/test/Control/Eff/State/OnDemand/Test.hs @@ -9,7 +9,6 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception -import Control.Eff.Lift import Control.Eff.State.OnDemand import Utils diff --git a/test/Control/Eff/State/Strict/Test.hs b/test/Control/Eff/State/Strict/Test.hs --- a/test/Control/Eff/State/Strict/Test.hs +++ b/test/Control/Eff/State/Strict/Test.hs @@ -8,7 +8,6 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception -import Control.Eff.Lift import Control.Eff.State.Strict import Control.Eff.Reader.Strict import Control.Eff.Writer.Strict diff --git a/test/Control/Eff/Test.hs b/test/Control/Eff/Test.hs --- a/test/Control/Eff/Test.hs +++ b/test/Control/Eff/Test.hs @@ -5,11 +5,17 @@ module Control.Eff.Test (testGroups) where +import Test.HUnit hiding (State) import Test.QuickCheck import Control.Eff import Control.Eff.Reader.Strict +import Control.Eff.State.Strict +import Control.Eff.Exception +import qualified Control.Exception as Exc +import Utils import Test.Framework.TH +import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 testGroups = [ $(testGroupGenerator) ] @@ -29,3 +35,204 @@ readerId = do x <- ask return x + +-- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved. +case_Lift_building :: Assertion +case_Lift_building = runLift possiblyAmbiguous + where + possiblyAmbiguous :: (Monad m, Lifted m r) => Eff r () + possiblyAmbiguous = lift $ return () + +case_Lift_tl1r :: Assertion +case_Lift_tl1r = do + ((), output) <- catchOutput tl1r + assertEqual "Test tl1r" (showLn input) output + where + input = (5::Int) + -- tl1r :: IO () + tl1r = runLift (runReader input tl1) + where + tl1 = ask >>= \(x::Int) -> lift . print $ x + +case_Lift_tMd' :: Assertion +case_Lift_tMd' = do + actual <- catchOutput tMd' + let expected = (output, (showLines input)) + assertEqual "Test mapMdebug using Lift" expected actual + where + input = [1..5] + val = (10::Int) + output = map (+ val) input + + tMd' = runLift $ runReader val $ mapMdebug' f input + where f x = ask `add` return x + + -- Re-implemenation of mapMdebug using Lifting + -- The signature is inferred + mapMdebug' :: (Show a, Lifted IO r) => + (a -> Eff r b) -> [a] -> Eff r [b] + mapMdebug' _f [] = return [] + mapMdebug' f (h:t) = do + lift $ print h + h' <- f h + t' <- mapMdebug' f t + return (h':t') + +-- tests from +data MyException = MyException String deriving (Show) +instance Exc.Exception MyException + +exfn :: Lifted IO r => Bool -> Eff r Bool +exfn True = lift . Exc.throw $ (MyException "thrown") +exfn False = return True + +testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s) + +case_catchDynE_test1 :: Assertion +case_catchDynE_test1 = do + ((), actual) <- catchOutput test1 + let expected = unlines [ "(\"thrown\",[\"begin\"])" + , "(\"True\",[\"end\",\"begin\"])"] + assertEqual "catchDynE: test1: exception shouldn't drop Writer's state" + expected actual + where + -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- + -- that is, an exception will drop the Writer's state, even if that + -- exception is caught. Here, the state is preserved! + -- So, this is an advantage over MTL! + test1 = do runLift (tf True) >>= print; runLift (tf False) >>= print + tf x = runReader (x::Bool) . runState ([]::[String]) $ testc m + m = do + modify ("begin":) + x <- ask + r <- exfn x + modify ("end":) + return r + +-- Let us use an Error effect instead +case_catchDynE_test1' :: Assertion +case_catchDynE_test1' = do + ((), actual') <- catchOutput test1' + let expected' = unlines [ "(Left \"thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertEqual "catchDynE: test1': Error shouldn't drop Writer's state" + expected' actual' + where + -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- + -- that is, an exception will drop the Writer's state, even if that + -- exception is caught. Here, the state is preserved! + -- So, this is an advantage over MTL! + test1' = do runLift (tf True) >>= print; runLift (tf False) >>= print + tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) + m = do + modify ("begin":) + x <- ask + r <- exfn x + modify ("end":) + return r + + runErrorStr = asEStr . runError + asEStr :: m (Either String a) -> m (Either String a) + asEStr = id + exfn True = throwError $ ("thrown") + exfn False = return True + +-- Now, the behavior of the dynamic Exception and Error effect is consistent. +-- The state is preserved. Before it wasn't. +case_catchDynE_test2 :: Assertion +case_catchDynE_test2 = do + ((), actual) <- catchOutput test2 + let expected = unlines [ "(Left \"thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertEqual "catchDynE: test2: Error shouldn't drop Writer's state" + expected actual + where + test2 = do runLift (tf True) >>= print; runLift (tf False) >>= print + tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) + runErrorStr = asEStr . runError + asEStr :: m (Either String a) -> m (Either String a) + asEStr = id + m = do + modify ("begin":) + x <- ask + r <- exfn x `catchDynE` (\ (MyException s) -> throwError s) + modify ("end":) + return r + +-- Full recovery +case_catchDynE_test2' :: Assertion +case_catchDynE_test2' = do + ((), actual) <- catchOutput test2' + let expected = unlines [ "(Right \"False\",[\"end\",\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertEqual "catchDynE: test2': Fully recover from errors" + expected actual + where + test2' = do runLift (tf True) >>= print; runLift (tf False) >>= print + tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) + runErrorStr = asEStr . runError + asEStr :: m (Either String a) -> m (Either String a) + asEStr = id + m = do + modify ("begin":) + x <- ask + r <- exfn x `catchDynE` (\ (MyException _s) -> return False) + modify ("end":) + return r + +-- Throwing within a handler +case_catchDynE_test3 :: Assertion +case_catchDynE_test3 = do + ((), actual) <- catchOutput test3 + let expected = unlines [ "(Right \"rethrow:thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertEqual "catchDynE: test3: Throwing within a handler" + expected actual + where + test3 = do runLift (tf True) >>= print; runLift (tf False) >>= print + tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) + runErrorStr = asEStr . runError + asEStr :: m (Either String a) -> m (Either String a) + asEStr = id + m = do + modify ("begin":) + x <- ask + r <- exfn x `catchDynE` (\ (MyException s) -> + lift . Exc.throw . MyException $ + ("rethrow:" ++ s)) + modify ("end":) + return r + +-- Implement the transactional behavior: when the exception is raised, +-- the state is rolled back to what it existed at the entrance to +-- the catch block. +-- This is the ``scoping behavior'' of `Handlers in action' +case_catchDynE_tran :: Assertion +case_catchDynE_tran = do + ((), actual) <- catchOutput tran + let expected = unlines ["(\"thrown\",[\"init\"])" + ,"(\"True\",[\"end\",\"begin\",\"init\"])"] + assertEqual "catchDynE: tran: Transactional behaviour" + expected actual + where + tran = do runLift (tf True) >>= print; runLift (tf False) >>= print + tf x = runReader (x :: Bool) . runState ([]::[String]) $ m1 + m1 = do + modify ("init":) + testc (transactionState (TxState :: TxState [String]) m) + m = do + modify ("begin":) + x <- ask + r <- exfn x + modify ("end":) + return r +{- -- without transaction +("thrown",["begin","init"]) +("True",["end","begin","init"]) +-} + +-- With transaction +{- +("thrown",["init"]) +("True",["end","begin","init"]) +-} diff --git a/test/Control/Eff/Writer/Lazy/Test.hs b/test/Control/Eff/Writer/Lazy/Test.hs --- a/test/Control/Eff/Writer/Lazy/Test.hs +++ b/test/Control/Eff/Writer/Lazy/Test.hs @@ -9,7 +9,6 @@ import Test.QuickCheck import Control.Eff -import Control.Eff.Lift import Control.Eff.Reader.Lazy import Control.Eff.Writer.Lazy import Utils diff --git a/test/Control/Eff/Writer/Strict/Test.hs b/test/Control/Eff/Writer/Strict/Test.hs --- a/test/Control/Eff/Writer/Strict/Test.hs +++ b/test/Control/Eff/Writer/Strict/Test.hs @@ -7,7 +7,6 @@ import Test.HUnit hiding (State) import Control.Eff -import Control.Eff.Lift import Control.Eff.Writer.Strict import Utils diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -7,7 +7,6 @@ import qualified Control.Eff.Example.Test import qualified Control.Eff.Exception.Test import qualified Control.Eff.Fresh.Test -import qualified Control.Eff.Lift.Test import qualified Control.Eff.NdetEff.Test import qualified Control.Eff.Operational.Test import qualified Control.Eff.Reader.Lazy.Test @@ -34,7 +33,6 @@ ++ Control.Eff.Example.Test.testGroups ++ Control.Eff.Exception.Test.testGroups ++ Control.Eff.Fresh.Test.testGroups - ++ Control.Eff.Lift.Test.testGroups ++ Control.Eff.NdetEff.Test.testGroups ++ Control.Eff.Operational.Test.testGroups ++ Control.Eff.Reader.Lazy.Test.testGroups