extensible-effects 2.5.0.0 → 2.5.1.0

raw patch · 27 files changed

+592/−279 lines, 27 filesdep +monad-controldep −transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monad-control

Dependencies removed: transformers

API changes (from Hackage documentation)

Files

• extensible-effects.cabal +8/−6
• src/Control/Eff.hs +5/−227
• src/Control/Eff/Choose.hs +17/−3
• src/Control/Eff/Exception.hs +16/−2
• src/Control/Eff/Fresh.hs +34/−6
• src/Control/Eff/Internal.hs +266/−0
• src/Control/Eff/Lift.hs +11/−24
• src/Control/Eff/NdetEff.hs +21/−2
• src/Control/Eff/Reader/Lazy.hs +17/−1
• src/Control/Eff/Reader/Strict.hs +17/−1
• src/Control/Eff/State/Lazy.hs +19/−1
• src/Control/Eff/State/OnDemand.hs +20/−1
• src/Control/Eff/State/Strict.hs +20/−1
• src/Control/Eff/Writer/Lazy.hs +19/−2
• src/Control/Eff/Writer/Strict.hs +19/−2
• test/Control/Eff/Choose/Test.hs +4/−0
• test/Control/Eff/Exception/Test.hs +8/−0
• test/Control/Eff/Fresh/Test.hs +6/−0
• test/Control/Eff/NdetEff/Test.hs +6/−0
• test/Control/Eff/Reader/Lazy/Test.hs +8/−0
• test/Control/Eff/Reader/Strict/Test.hs +8/−0
• test/Control/Eff/State/Lazy/Test.hs +7/−0
• test/Control/Eff/State/OnDemand/Test.hs +8/−0
• test/Control/Eff/State/Strict/Test.hs +7/−0
• test/Control/Eff/Writer/Lazy/Test.hs +7/−0
• test/Control/Eff/Writer/Strict/Test.hs +7/−0
• test/Utils.hs +7/−0

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             2.5.0.0+version:             2.5.1.0  -- A short (one-line) description of the package. synopsis:            An Alternative to Monad Transformers@@ -88,7 +88,8 @@                        Data.OpenUnion    -- Modules included in this library but not exported.-  other-modules:       Data.FTCQueue+  other-modules:       Control.Eff.Internal+                       Data.FTCQueue   if flag(force-openunion-51)     cpp-options:       -DFORCE_OU51 @@ -134,10 +135,10 @@    -- Other library packages from which modules are imported.   build-depends:       base >= 4.7 && < 4.11-                       -- For MonadIO instance-                       , transformers >= 0.3 && < 0.6-                       -- For MonadBase instance-                       , transformers-base == 0.4.*+                       -- For MonadBase+               ,       transformers-base == 0.4.*+                       -- For MonadBaseControl+               ,       monad-control >= 1.0 && < 1.1    -- Directories containing source files.   hs-source-dirs:      src@@ -184,6 +185,7 @@                 base >= 4.7 && < 4.11               , QuickCheck               , HUnit+              , monad-control >= 1.0               , silently >= 1.2               , test-framework == 0.8.*               , test-framework-hunit == 0.3.*

@@ -1,228 +1,6 @@-{-# OPTIONS_GHC -Werror #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DataKinds #-}--{-# LANGUAGE CPP #-}---- --------------------------------------------------------------------------- | A monadic library for communication between a handler and--- its client, the administered computation------ Original work available at <http://okmij.org/ftp/Haskell/extensible/tutorial.html>.--- This module implements extensible effects as an alternative to monad transformers,--- as described in <http://okmij.org/ftp/Haskell/extensible/exteff.pdf> and--- <http://okmij.org/ftp/Haskell/extensible/more.pdf>.------ Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype.--- A contrived example can be found under "Control.Eff.Example". To run the--- effects, consult the tests.-module Control.Eff (-  module Control.Eff-  , module Data.OpenUnion-  ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import qualified Control.Arrow as A-import qualified Control.Category as C-import safe Data.OpenUnion-import safe Data.FTCQueue-import GHC.Exts (inline)---- | Effectful arrow type: a function from a to b that also does effects--- denoted by r-type Arr r a b = a -> Eff r b---- | An effectful function from 'a' to 'b' that is a composition of one or more--- effectful functions. The paremeter r describes the overall effect.------ The composition members are accumulated in a type-aligned queue.--- Using a newtype here enables us to define `Category' and `Arrow' instances.-newtype Arrs r a b = Arrs (FTCQueue (Eff r) a b)---- | 'Arrs' can be composed and have a natural identity.-instance C.Category (Arrs r) where-  id = ident-  f . g = comp g f---- | As the name suggests, 'Arrs' also has an 'Arrow' instance.-instance A.Arrow (Arrs r) where-  arr = arr-  first = singleK . first . (^$)--first :: Arr r a b -> Arr r (a, c) (b, c)-first x = \(a,c) -> (, c) `fmap` x a---- | convert single effectful arrow into composable type. i.e., convert 'Arr' to--- 'Arrs'-{-# INLINE singleK #-}-singleK :: Arr r a b -> Arrs r a b-singleK = Arrs . tsingleton---- | Application to the `generalized effectful function' Arrs r b w, i.e.,--- convert 'Arrs' to 'Arr'-{-# INLINABLE qApp #-}-qApp :: forall r b w. Arrs r b w -> Arr r b w-qApp (Arrs q) x = viewlMap (inline tviewl q) ($ x) cons-  where-    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))-{---- A bit more understandable version-qApp :: Arrs r b w -> b -> Eff r w-qApp q x = case tviewl q of-   TOne k  -> k x-   k :| t -> bind' (k x) t- where-   bind' :: Eff r a -> Arrs r a b -> Eff r b-   bind' (Pure y) k     = qApp k y-   bind' (Impure u q) k = Impure u (q >< k)--}---- | Syntactic sugar for 'qApp'-{-# INLINABLE (^$) #-}-(^$) :: forall r b w. Arrs r b w -> Arr r b w-q ^$ x = q `qApp` x---- | Lift a function to an arrow-arr :: (a -> b) -> Arrs r a b-arr f = singleK (Val . f)---- | The identity arrow-ident :: Arrs r a a-ident = arr id---- | Arrow composition-comp :: Arrs r a b -> Arrs r b c -> Arrs r a c-comp (Arrs f) (Arrs g) = Arrs (f >< g)---- | Common pattern: append 'Arr' to 'Arrs'-(^|>) :: Arrs r a b -> Arr r b c -> Arrs r a c-(Arrs f) ^|> g = Arrs (f |> g)---- | The Eff monad (not a transformer!). It is a fairly standard coroutine monad--- where the type @r@ is the type of effects that can be handled, and the--- missing type @a@ (from the type application) is the type of value that is--- returned.  It is NOT a Free monad! There are no Functor constraints.------ The two constructors denote the status of a coroutine (client): done with the--- value of type a, or sending a request of type Union r with the continuation--- Arrs r b a. Expressed another way: an `Eff` can either be a value (i.e.,--- 'Val' case), or an effect of type @`Union` r@ producing another `Eff` (i.e.,--- 'E' case). The result is that an `Eff` can produce an arbitrarily long chain--- of @`Union` r@ effects, terminated with a pure value.------ Potentially, inline Union into E-data Eff r a = Val a-             | forall b. E  (Union r b) (Arrs r b a)---- | 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 g h = (h . (g `qApp`))-qComp g h = \a -> h $ (g ^$ a)---- | 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---- | Eff is still a monad and a functor (and Applicative)--- (despite the lack of the Functor constraint)-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!--instance Applicative (Eff r) where-  {-# INLINE pure #-}-  pure = Val-  Val f <*> e = f `fmap` e-  E u q <*> e = E u (q ^|> (`fmap` e))--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-{--  Val _ >> m = m-  E u q >> m = E u (q ^|> const m)--}---- | 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)--- 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)- #-}----- --------------------------------------------------------------------------- | The initial case, no effects. Get the result from a pure computation.------ The type of run ensures that all effects must be handled:--- only pure computations may be run.-run :: Eff '[] w -> w-run (Val x) = x--- | the other case is unreachable since Union [] a cannot be--- constructed.--- Therefore, run is a total function if its argument terminates.-run (E _ _) = 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---- | 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-  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+module Control.Eff ( module Internal+                   , module OpenUnion+                   ) where --- | Add something like Control.Exception.catches? It could be useful--- for control with cut.------ Intercept the request and possibly reply to it, but leave it unhandled--- (that's why we use the same r 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+import Control.Eff.Internal as Internal hiding (Lift(..), lift, runLift)+import Data.OpenUnion as OpenUnion

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -18,11 +19,14 @@                           , mplus'                           ) where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion #if __GLASGOW_HASKELL__ > 708 import Control.Applicative-import Control.Monad #endif+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control  -- ------------------------------------------------------------------------ -- | Non-determinism (choice)@@ -34,6 +38,16 @@ -- any constraints. newtype Choose a = Choose [a] +instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff r)+         ) => MonadBaseControl m (Eff (Choose ': r)) where+    type StM (Eff (Choose ': r)) a = StM (Eff r) [a]+    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->+                       f (runInBase . makeChoice)+    restoreM x = do lst <- raise (restoreM x)+                    choose lst+ -- | choose lst non-deterministically chooses one value from the lst -- choose [] thus corresponds to failure choose :: Member Choose r => [a] -> Eff r a@@ -45,7 +59,7 @@  -- | MonadPlus-like operators are expressible via choose mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a-mplus' m1 m2 = choose [m1,m2] >>= id+mplus' m1 m2 = join $ choose [m1,m2]  #if __GLASGOW_HASKELL__ > 708 -- | MonadPlus-like operators are expressible via choose

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -21,16 +23,28 @@                             , ignoreFail                             ) where -import Control.Eff-import Control.Eff.Lift+import Control.Eff.Internal+import Data.OpenUnion  import Control.Monad (void)+import Control.Monad.Base+import Control.Monad.Trans.Control  -- ------------------------------------------------------------------------ -- | Exceptions -- -- exceptions of the type e; no resumption newtype Exc e v = Exc e++instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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 ->+                       f (runInBase . runError)+    restoreM x = do r :: Either e a <- raise (restoreM x)+                    liftEither r  type Fail = Exc () 

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -6,13 +8,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE Safe #-} -- | Create unique Enumerable values.-module Control.Eff.Fresh( Fresh (..)+module Control.Eff.Fresh( Fresh (Fresh)                         , fresh                         , runFresh'                         ) where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion +import Control.Monad.Base+import Control.Monad.Trans.Control++ -- There are three possible implementations -- The first one uses State Fresh where --    newtype Fresh = Fresh Int@@ -25,18 +32,39 @@ -- | Create unique Enumerable values. data Fresh v where   Fresh :: Fresh Int+  Replace :: !Int -> Fresh () +instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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)+    restoreM x = do (r,i) <- raise (restoreM x)+                    replace i+                    return r++ -- | Produce a value that has not been previously produced. fresh :: Member Fresh r => Eff r Int fresh = send Fresh +replace :: Member Fresh r => Int -> Eff r ()+replace = send . Replace+ -- | Run an effect requiring unique values. runFresh' :: Eff (Fresh ': r) w -> Int -> Eff r w-runFresh' m s =-  handle_relay_s s (\_s x -> return x)-                   (\s' Fresh k -> (k $! s' + 1) s')-                   m+runFresh' m s = fst `fmap` runFreshReturn m s +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 {- -- Finally, the worst implementation but the one that answers -- reviewer's question: implementing Fresh in terms of State

@@ -0,0 +1,266 @@+{-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE CPP #-}++-- ------------------------------------------------------------------------+-- | A monadic library for communication between a handler and+-- its client, the administered computation+--+-- Original work available at <http://okmij.org/ftp/Haskell/extensible/tutorial.html>.+-- This module implements extensible effects as an alternative to monad transformers,+-- as described in <http://okmij.org/ftp/Haskell/extensible/exteff.pdf> and+-- <http://okmij.org/ftp/Haskell/extensible/more.pdf>.+--+-- Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype.+-- A contrived example can be found under "Control.Eff.Example". To run the+-- effects, consult the tests.+module Control.Eff.Internal ( 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.Trans.Control (MonadBaseControl(..))+import safe Data.OpenUnion+import safe Data.FTCQueue+import GHC.Exts (inline)++-- | Effectful arrow type: a function from a to b that also does effects+-- denoted by r+type Arr r a b = a -> Eff r b++-- | An effectful function from 'a' to 'b' that is a composition of one or more+-- effectful functions. The paremeter r describes the overall effect.+--+-- The composition members are accumulated in a type-aligned queue.+-- Using a newtype here enables us to define `Category' and `Arrow' instances.+newtype Arrs r a b = Arrs (FTCQueue (Eff r) a b)++-- | 'Arrs' can be composed and have a natural identity.+instance C.Category (Arrs r) where+  id = ident+  f . g = comp g f++-- | As the name suggests, 'Arrs' also has an 'Arrow' instance.+instance A.Arrow (Arrs r) where+  arr = arr+  first = singleK . first . (^$)++first :: Arr r a b -> Arr r (a, c) (b, c)+first x = \(a,c) -> (, c) `fmap` x a++-- | convert single effectful arrow into composable type. i.e., convert 'Arr' to+-- 'Arrs'+{-# INLINE singleK #-}+singleK :: Arr r a b -> Arrs r a b+singleK = Arrs . tsingleton++-- | Application to the `generalized effectful function' Arrs r b w, i.e.,+-- convert 'Arrs' to 'Arr'+{-# INLINABLE qApp #-}+qApp :: forall r b w. Arrs r b w -> Arr r b w+qApp (Arrs q) x = viewlMap (inline tviewl q) ($ x) cons+  where+    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))+{-+-- A bit more understandable version+qApp :: Arrs r b w -> b -> Eff r w+qApp q x = case tviewl q of+   TOne k  -> k x+   k :| t -> bind' (k x) t+ where+   bind' :: Eff r a -> Arrs r a b -> Eff r b+   bind' (Pure y) k     = qApp k y+   bind' (Impure u q) k = Impure u (q >< k)+-}++-- | Syntactic sugar for 'qApp'+{-# INLINABLE (^$) #-}+(^$) :: forall r b w. Arrs r b w -> Arr r b w+q ^$ x = q `qApp` x++-- | Lift a function to an arrow+arr :: (a -> b) -> Arrs r a b+arr f = singleK (Val . f)++-- | The identity arrow+ident :: Arrs r a a+ident = arr id++-- | Arrow composition+comp :: Arrs r a b -> Arrs r b c -> Arrs r a c+comp (Arrs f) (Arrs g) = Arrs (f >< g)++-- | Common pattern: append 'Arr' to 'Arrs'+(^|>) :: Arrs r a b -> Arr r b c -> Arrs r a c+(Arrs f) ^|> g = Arrs (f |> g)++-- | The Eff monad (not a transformer!). It is a fairly standard coroutine monad+-- where the type @r@ is the type of effects that can be handled, and the+-- missing type @a@ (from the type application) is the type of value that is+-- returned.  It is NOT a Free monad! There are no Functor constraints.+--+-- The two constructors denote the status of a coroutine (client): done with the+-- value of type a, or sending a request of type Union r with the continuation+-- Arrs r b a. Expressed another way: an `Eff` can either be a value (i.e.,+-- 'Val' case), or an effect of type @`Union` r@ producing another `Eff` (i.e.,+-- 'E' case). The result is that an `Eff` can produce an arbitrarily long chain+-- of @`Union` r@ effects, terminated with a pure value.+--+-- Potentially, inline Union into E+data Eff r a = Val a+             | forall b. E  (Union r b) (Arrs r b a)++-- | 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 g h = (h . (g `qApp`))+qComp g h = \a -> h $ (g ^$ a)++-- | 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++-- | Eff is still a monad and a functor (and Applicative)+-- (despite the lack of the Functor constraint)+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!++instance Applicative (Eff r) where+  {-# INLINE pure #-}+  pure = Val+  Val f <*> e = f `fmap` e+  E u q <*> e = E u (q ^|> (`fmap` e))++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+{-+  Val _ >> m = m+  E u q >> m = E u (q ^|> const m)+-}++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)+    restoreM = return++-- | 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)+-- 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)+ #-}+++-- ------------------------------------------------------------------------+-- | The initial case, no effects. Get the result from a pure computation.+--+-- The type of run ensures that all effects must be handled:+-- only pure computations may be run.+run :: Eff '[] w -> w+run (Val x) = x+-- | the other case is unreachable since Union [] a cannot be+-- constructed.+-- Therefore, run is a total function if its argument terminates.+run (E _ _) = 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++-- | 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+  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++-- | Add something like Control.Exception.catches? It could be useful+-- for control with cut.+--+-- Intercept the request and possibly reply to it, but leave it unhandled+-- (that's why we use the same r 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++-- | 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+  where+    loop (Val x) = pure x+    loop (E u q) = E (weaken u) $ qComps q loop+{-# INLINE raise #-}++-- ------------------------------------------------------------------------+-- | Lifting: emulating monad transformers+newtype Lift m a = Lift (m a)++-- | We make the Lift layer to be unique, using SetMember+lift :: (SetMember Lift (Lift 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.+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"+

@@ -1,40 +1,27 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# 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 (..)-                       , lift-                       , runLift-                       , catchDynE-                       ) where+                        , Lifted+                        , lift+                        , runLift+                        , catchDynE+                        ) where -import Control.Eff+import Control.Eff.Internal import qualified Control.Exception as Exc---- --------------------------------------------------------------------------- | Lifting: emulating monad transformers-newtype Lift m a = Lift (m a)---- | We make the Lift layer to be unique, using SetMember-lift :: (SetMember Lift (Lift m) r) => m a -> Eff r a-lift = send . Lift+import Data.OpenUnion --- | The handler of Lift requests. It is meant to be terminal:--- we only allow a single Lifted Monad.-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"+-- |A convenient alias to 'SetMember Lift (Lift m) r'+type Lifted m r = SetMember Lift (Lift m) r  -- | Catching of dynamic exceptions -- See the problem in -- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO catchDynE :: forall e a r.-             (SetMember Lift (Lift IO) r, Exc.Exception e) =>+             (Lifted IO r, Exc.Exception e) =>              Eff r a -> (e -> Eff r a) -> Eff r a catchDynE m eh = interpose return h m  where

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Werror -fno-warn-orphans #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -13,10 +14,14 @@ -- | Another implementation of nondeterministic choice effect module Control.Eff.NdetEff where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion -import Control.Monad import Control.Applicative+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.Foldable (foldl')  -- | A different implementation, more directly mapping to MonadPlus -- interface@@ -32,6 +37,16 @@   mzero = send MZero   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)+         ) => MonadBaseControl m (Eff (NdetEff ': r)) where+    type StM (Eff (NdetEff ': r)) a = StM (Eff r) [a]+    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->+                       f (runInBase . makeChoiceLst)+    restoreM x = do lst :: [a] <- raise (restoreM x)+                    foldl' (\r a -> r <|> pure a) mzero lst+ -- | An interpreter -- The following is very simple, but leaks a lot of memory -- The cause probably is mapping every failure to empty@@ -57,6 +72,10 @@      Right MPlus -> loop (q ^$ False : jq) (q ^$ True)      Left  u0 -> E u0 (singleK (\x -> loop jq (q ^$ x))) +-- | 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,

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -13,8 +15,12 @@                               , runReader                               ) where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion +import Control.Monad.Base+import Control.Monad.Trans.Control+ -- ------------------------------------------------------------------------ -- | The Reader monad --@@ -67,3 +73,13 @@ -- | 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)+         ) => MonadBaseControl m (Eff (Reader e ': s)) where+    type StM (Eff (Reader e ': s)) a = StM (Eff s) a+    liftBaseWith f = do e <- ask+                        raise $ liftBaseWith $ \runInBase ->+                          f (\k -> runInBase $ runReader k e)+    restoreM = raise . restoreM

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -14,8 +16,12 @@                               , runReader                               ) where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion +import Control.Monad.Base+import Control.Monad.Trans.Control+ -- ------------------------------------------------------------------------ -- | The Reader monad --@@ -68,3 +74,13 @@ -- | 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)+         ) => MonadBaseControl m (Eff (Reader e ': s)) where+    type StM (Eff (Reader e ': s)) a = StM (Eff s) a+    liftBaseWith f = do !e <- ask+                        raise $ liftBaseWith $ \runInBase ->+                          f (\k -> runInBase $ runReader k e)+    restoreM = raise . restoreM

@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}@@ -10,10 +12,14 @@ -- | Lazy state effect module Control.Eff.State.Lazy where -import Control.Eff+import Control.Eff.Internal import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy+import Data.OpenUnion +import Control.Monad.Base+import Control.Monad.Trans.Control+ -- ------------------------------------------------------------------------ -- | State, lazy --@@ -34,6 +40,18 @@ data State s v where   Get :: State s s   Put :: s -> State s ()++instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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+                        raise $ liftBaseWith $ \runInBase ->+                          f (\k -> runInBase $ runState k s)+    restoreM x = do (a, s :: s) <- raise (restoreM x)+                    put s+                    return a  -- | Return the current value of the state. The signatures are inferred {-# NOINLINE get #-}

@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}@@ -10,10 +12,14 @@ -- | Lazy state effect module Control.Eff.State.OnDemand where -import Control.Eff+import Control.Eff.Internal import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy+import Data.OpenUnion +import Control.Monad.Base+import Control.Monad.Trans.Control+ -- ------------------------------------------------------------------------ -- | State, lazy (i.e., on-demand) --@@ -25,6 +31,19 @@   Get  :: OnDemandState s s   Put  :: s -> OnDemandState s ()   Delay :: Eff '[OnDemandState s] a  -> OnDemandState s a --  Eff as a transformer++instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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+                        raise $ liftBaseWith $ \runInBase ->+                          f (\k -> runInBase $ runState k s)+    restoreM x = do (a, s :: s) <- raise (restoreM x)+                    put s+                    return a+  -- | Return the current value of the state. The signatures are inferred {-# NOINLINE get #-}

@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -11,10 +13,14 @@ -- | Strict state effect module Control.Eff.State.Strict where -import Control.Eff+import Control.Eff.Internal import Control.Eff.Writer.Strict import Control.Eff.Reader.Strict+import Data.OpenUnion +import Control.Monad.Base+import Control.Monad.Trans.Control+ -- ------------------------------------------------------------------------ -- | State, strict --@@ -35,6 +41,19 @@ data State s v where   Get :: State s s   Put :: !s -> State s ()++instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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+                        raise $ liftBaseWith $ \runInBase ->+                          f (\k -> runInBase $ runState k s)+    restoreM x = do !(a, s :: s) <- raise (restoreM x)+                    put s+                    return a+  -- | Return the current value of the state. The signatures are inferred {-# NOINLINE get #-}

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -16,11 +18,15 @@                                , runMonoidWriter                                ) where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion -import Data.Monoid import Control.Applicative ((<|>)) +import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.Monoid+ -- ------------------------------------------------------------------------ -- | The Writer monad --@@ -30,6 +36,17 @@ -- the |Monoid w| constraint then data Writer w v where   Tell :: w -> Writer w ()++instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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 ->+                       f (runInBase . runListWriter)+    restoreM x = do (a, ws :: [w]) <- raise (restoreM x)+                    mapM_ tell ws+                    return a  -- | Write a new value. tell :: Member (Writer w) r => w -> Eff r ()

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -17,11 +19,15 @@                                , runMonoidWriter                                ) where -import Control.Eff+import Control.Eff.Internal+import Data.OpenUnion -import Data.Monoid import Control.Applicative ((<|>)) +import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.Monoid+ -- ------------------------------------------------------------------------ -- | The Writer monad --@@ -31,6 +37,17 @@ -- the |Monoid w| constraint then data Writer w v where   Tell :: !w -> Writer w ()++instance ( MonadBase m m+         , SetMember Lift (Lift m) r+         , MonadBaseControl m (Eff 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 ->+                       f (runInBase . runListWriter)+    restoreM x = do !(a, ws :: [w]) <- raise (restoreM x)+                    mapM_ tell ws+                    return a  -- | Write a new value. tell :: Member (Writer w) r => w -> Eff r ()

@@ -8,6 +8,7 @@ import Control.Eff.Example import Control.Eff.Example.Test (ex2) import Control.Eff.Exception+import Control.Eff.Lift import Control.Eff.Choose import Utils @@ -55,3 +56,6 @@     exRec m = catchError m handler       where handler (TooBig n) | n <= 7 = return n             handler e = throwError e++case_Choose_monadBaseControl :: Assertion+case_Choose_monadBaseControl = runLift (makeChoice $ doThing $ choose [1,2,3]) @=? Just [1,2,3]

@@ -9,6 +9,7 @@ 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@@ -92,3 +93,10 @@         tell (4 :: Int)         return 5    in assertEqual "Fail should stop writing" 6 ret++case_Exception1_monadBaseControl :: Assertion+case_Exception1_monadBaseControl =+    runLift (runError act) @=? Just (Left "Fail")+  where+    act = doThing $ do _ <- throwError "Fail"+                       return "Success"

@@ -7,6 +7,7 @@  import Test.HUnit hiding (State) import Control.Eff.Fresh+import Control.Eff.Lift import Control.Eff.Trace import Utils @@ -26,3 +27,8 @@       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)+  where+    i = 0

@@ -5,10 +5,13 @@ module Control.Eff.NdetEff.Test (testGroups) 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)+import Utils  import Test.Framework.TH import Test.Framework.Providers.HUnit@@ -70,3 +73,6 @@     tsplit =       (tell "begin" >> return 1) `mplus`       (tell "end"   >> return 2)++case_NdetEff_monadBaseControl :: Assertion+case_NdetEff_monadBaseControl = runLift (makeChoiceA $ doThing (return 1 <|> return 2)) @=? Just [1,2]

@@ -8,6 +8,7 @@  import Test.HUnit hiding (State) import Control.Eff+import Control.Eff.Lift import Control.Eff.Reader.Lazy import Control.Monad import Utils@@ -95,3 +96,10 @@     voidReader = do         _ <- (ask :: Eff '[Reader ()] ())         return ()++case_Lazy1_Reader_monadBaseControl :: Assertion+case_Lazy1_Reader_monadBaseControl =+      runLift (runReader act i) @=? (Just i)+    where+        act = doThing ask+        i = 10 :: Int

@@ -7,6 +7,7 @@  import Test.HUnit hiding (State) import Control.Eff+import Control.Eff.Lift import Control.Eff.Reader.Strict import Utils @@ -24,3 +25,10 @@     voidReader = do         _ <- (ask :: Eff '[Reader ()] ())         return ()++case_Strict1_Reader_monadBaseControl :: Assertion+case_Strict1_Reader_monadBaseControl =+      runLift (runReader act i) @=? (Just i)+    where+        act = doThing ask+        i = 10 :: Int

@@ -7,6 +7,7 @@  import Test.HUnit hiding (State) import Control.Eff+import Control.Eff.Lift import Control.Eff.State.Lazy import Utils @@ -30,3 +31,9 @@      putVoid :: () -> Eff '[State ()] ()     putVoid = put++case_Lazy1_State_monadBaseControl :: Assertion+case_Lazy1_State_monadBaseControl = runLift (runState (doThing $ modify f) i) @=? Just ((), i + 1)+  where+    i = 0 :: Int+    f = succ :: Int -> Int

@@ -9,7 +9,9 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception+import Control.Eff.Lift import Control.Eff.State.OnDemand+import Utils  import Test.Framework.TH import Test.Framework.Providers.HUnit@@ -106,3 +108,9 @@         put ((1::Int):s)   in     assertEqual "OnDemandState ones" [1,1,1,1,1] (take 5 ones)++case_LazierState_monadBaseControl :: Assertion+case_LazierState_monadBaseControl = runLift (runState (doThing $ modify f) i) @=? Just ((), i + 1)+  where+    i = 0 :: Int+    f = succ :: Int -> Int

@@ -8,6 +8,7 @@ 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@@ -99,3 +100,9 @@ case_Strict1_State_ter4 :: Assertion case_Strict1_State_ter4 = (Right ("exc",2) :: Either String (String,Int)) @=?   (run $ runError (runState (teCatch tes1) (1::Int)))++case_Strict1_State_monadBaseControl :: Assertion+case_Strict1_State_monadBaseControl = runLift (runState (doThing $ modify f) i) @=? Just ((), i + 1)+  where+    i = 0 :: Int+    f = succ :: Int -> Int

@@ -9,6 +9,7 @@ import Test.QuickCheck  import Control.Eff+import Control.Eff.Lift import Control.Eff.Reader.Lazy import Control.Eff.Writer.Lazy import Utils@@ -57,3 +58,9 @@   ((), Just m) = run $ runLastWriter $ mapM_ tell [undefined, ()]   in    assertNoUndefined (m :: ())++case_Lazy1_Writer_monadBaseControl :: Assertion+case_Lazy1_Writer_monadBaseControl = runLift (runListWriter act) @=? Just ((), [i])+  where+    i = 10 :: Int+    act = doThing (tell i)

@@ -7,6 +7,7 @@  import Test.HUnit hiding (State) import Control.Eff+import Control.Eff.Lift import Control.Eff.Writer.Strict import Utils @@ -20,3 +21,9 @@   ((), Just m) = run $ runLastWriter $ mapM_ tell [undefined, ()]   in    assertUndefined (m :: ())++case_Strict1_Writer_monadBaseControl :: Assertion+case_Strict1_Writer_monadBaseControl = runLift (runListWriter act) @=? Just ((), [i])+  where+    i = 10 :: Int+    act = doThing (tell i)

@@ -4,6 +4,7 @@  import Control.Exception (ErrorCall, catch) import Control.Monad+import Control.Monad.Trans.Control  import System.IO.Silently import Data.Tuple (swap)@@ -41,3 +42,9 @@  add :: Monad m => m Int -> m Int -> m Int add = liftM2 (+)++doThing :: MonadBaseControl b m => m a -> m a+doThing = liftBaseOp_ go+  where+    go :: Monad m => m a -> m a+    go a = return () >> a