extensible-effects 1.8.0.0 → 1.8.1.0

raw patch · 19 files changed

+112/−71 lines, 19 filesdep +freedep +kan-extensionsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: free, kan-extensions

API changes (from Hackage documentation)

Files

• README.md +4/−2
• extensible-effects.cabal +3/−1
• src/Control/Eff.hs +41/−30
• src/Control/Eff/Choose.hs +2/−2
• src/Control/Eff/Coroutine.hs +2/−2
• src/Control/Eff/Cut.hs +2/−2
• src/Control/Eff/Exception.hs +4/−4
• src/Control/Eff/Fresh.hs +2/−2
• src/Control/Eff/Lift.hs +2/−2
• src/Control/Eff/Reader/Lazy.hs +4/−4
• src/Control/Eff/Reader/Strict.hs +4/−4
• src/Control/Eff/State/Lazy.hs +2/−2
• src/Control/Eff/State/Strict.hs +2/−2
• src/Control/Eff/Trace.hs +2/−2
• src/Control/Eff/Writer/Lazy.hs +4/−4
• src/Control/Eff/Writer/Strict.hs +4/−4
• src/Data/OpenUnion.hs +1/−1
• src/Data/OpenUnion/Internal/Base.hs +5/−0
• test/Test.hs +22/−1

@@ -22,6 +22,8 @@     involving the type `t` would need to be added, which would defeat the point     of having the grouping in the first place. -  * Requires a `Typeable` instance on the return type.+  * Requires a `Typeable` instance on the return type. This is no longer a+    limitation on GHC versions 7.8 and above.   * Neither `Eff` nor `(:>)` has a `Typeable` instance, and can thus often not-    be used as a return type (e.g. `State` type) for other `Eff`s.+    be used as a return type (e.g. `State` type) for other `Eff`s. This is no+    longer a concern for GHC versions 7.8 and above.

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.8.0.0+version:             1.8.1.0  -- A short (one-line) description of the package. synopsis:            An Alternative to Monad Transformers@@ -108,6 +108,8 @@    -- Other library packages from which modules are imported.   build-depends:       base >= 4.6 && < 5+                       , free >= 4.0 && < 5.0+                       , kan-extensions >= 4.0 && < 5.0                        -- For MonadIO instance                        , transformers >= 0.3 && < 0.5                        -- For MonadBase instance

@@ -10,8 +10,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708+-- needed for the orphan Typeable instance for Codensity below+{-# OPTIONS -fno-warn-orphans #-}+#endif  -- | Original work available at <http://okmij.org/ftp/Haskell/extensible/Eff.hs>. -- This module implements extensible effects as an alternative to monad transformers,@@ -63,8 +68,9 @@ -- > lastAndSum l = let (lst, (total, ())) = run $ runWriter $ runState 0 $ writeAndAdd l -- >                in (lst, total) module Control.Eff(-                    Eff (..)-                  , VE (..)+                    Eff+                  , VE+                  , Free (..)                   , Member                   , SetMember                   , Union@@ -81,8 +87,9 @@                   , unsafeReUnion                   ) where -import Control.Applicative (Applicative (..), (<$>))-import Control.Monad (ap)+import Control.Applicative ((<$>))+import Control.Monad.Codensity (Codensity (..))+import Control.Monad.Free (Free (..)) import Data.OpenUnion import Data.Typeable @@ -93,45 +100,49 @@ -- | A `VE` is either a value, or an effect of type @`Union` r@ producing another `VE`. -- The result is that a `VE` can produce an arbitrarily long chain of @`Union` r@ -- effects, terminated with a pure value.-data VE r w = Val w | E !(Union r (VE r w))-  deriving Typeable+--+-- As is made explicit here, `VE` is simply the Free monad resulting from the+-- @`Union` r@ functor.+type VE r = Free (Union r)  fromVal :: VE r w -> w-fromVal (Val w) = w+fromVal (Pure w) = w fromVal _ = error "extensible-effects: fromVal was called on a non-terminal effect." {-# INLINE fromVal #-} --- | Basic datatype returned by all computations with extensible effects.--- The type @r@ is the type of effects that can be handled,--- and @a@ is the type of value that is returned.-newtype Eff r a = Eff { runEff :: forall w. (a -> VE r w) -> VE r w }-  deriving Typeable--instance Functor (Eff r) where-    fmap f m = Eff $ \k -> runEff m (k . f)-    {-# INLINE fmap #-}--instance Applicative (Eff r) where-    pure = return-    (<*>) = ap--instance Monad (Eff r) where-    return x = Eff $ \k -> k x-    {-# INLINE return #-}--    m >>= f = Eff $ \k -> runEff m (\v -> runEff (f v) k)-    {-# INLINE (>>=) #-}+-- | Basic datatype returned by all computations with extensible effects. The+-- @`Eff` r@ type is a type synonym 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.+--+-- As is made explicit below, the `Eff` type is simply the application of the+-- Codensity transformer to `VE`:+--+--     @type `Eff` r a = `Codensity` (`VE` r) a@+--+-- This is done to gain the asymptotic speedups for scenarios where there is a+-- single 'execution' stage where the built up monadic computation gets+-- executed. For scenarios where the computation execution and building stages+-- are interspersed, the reflection without remorse techniques would be a+-- better fit. See <https://github.com/atzeus/reflectionwithoutremorse>.+type Eff r = Codensity (VE r)+#if __GLASGOW_HASKELL__ >= 708+-- as of version 4.1.0.1 Codensity in kan-extensions does not have a a Typeable+-- instance. it doesn't seem possible to be able to define an orphan Typeable+-- instance for Codensity in ghc-7.6+deriving instance Typeable Codensity+#endif  -- | Given a method of turning requests into results, -- we produce an effectful computation. send :: (forall w. (a -> VE r w) -> Union r (VE r w)) -> Eff r a-send f = Eff (E . f)+send f = Codensity (Free . f) {-# INLINE send #-}  -- | Tell an effectful computation that you're ready to start running effects -- and return a value. admin :: Eff r w -> VE r w-admin (Eff m) = m Val+admin (Codensity m) = m Pure {-# INLINE admin #-}  -- | Get the result from a pure computation.@@ -151,7 +162,7 @@ handleRelay u loop h = either passOn h $ decomp u   where passOn u' = send (<$> u') >>= loop   -- perhaps more efficient:-  -- passOn u' = send (\k -> fmap (\w -> runEff (loop w) k) u')+  -- passOn u' = send (\k -> fmap (\w -> runCodensity (loop w) k) u') {-# INLINE handleRelay #-}  -- | Given a request, either handle it or relay it. Both the handler

@@ -40,8 +40,8 @@ runChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a] runChoice m = loop (admin m)  where-  loop (Val x)  = return [x]-  loop (E u)    = handleRelay u loop (\(Choose lst k) -> handle lst k)+  loop (Pure x)  = return [x]+  loop (Free u)    = handleRelay u loop (\(Choose lst k) -> handle lst k)    handle :: [t] -> (t -> VE (Choose :> r) a) -> Eff r [a]   handle [] _  = return []

@@ -39,6 +39,6 @@ runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a w) runC m = loop (admin m)   where-    loop (Val x) = return (Done x)-    loop (E u)   = handleRelay u loop $+    loop (Pure x) = return (Done x)+    loop (Free u)   = handleRelay u loop $                     \(Yield x k) -> return (Y x (loop . k))

@@ -68,8 +68,8 @@ -- It completely handles CutFalse effects but not non-determinism. call :: Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a call m = loop [] (admin m) where- loop jq (Val x) = return x `mplus'` next jq          -- (C2)- loop jq (E u) = case decomp u of+ loop jq (Pure x) = return x `mplus'` next jq          -- (C2)+ loop jq (Free u) = case decomp u of     Right (Exc CutFalse) -> mzero'  -- drop jq (F2)     Left u' -> check jq u' 

@@ -49,8 +49,8 @@ runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a) runExc = loop . admin  where-  loop (Val x)  = return (Right x)-  loop (E u)    = handleRelay u loop (\(Exc e) -> return (Left e))+  loop (Pure x)  = return (Right x)+  loop (Free u)    = handleRelay u loop (\(Exc e) -> return (Left e))  -- | Runs a failable effect, such that failed computation return 'Nothing', and --   'Just' the return value on success.@@ -66,8 +66,8 @@          -> Eff r a catchExc m handle = loop (admin m)  where-  loop (Val x)  = return x-  loop (E u)    = interpose u loop (\(Exc e) -> handle e)+  loop (Pure x)  = return x+  loop (Free u)    = interpose u loop (\(Exc e) -> handle e)  -- | Add a default value (i.e. failure handler) to a fallible computation. -- This hides the fact that a failure happened.

@@ -25,6 +25,6 @@ runFresh :: (Typeable i, Enum i) => Eff (Fresh i :> r) w -> i -> Eff r w runFresh m s0 = loop s0 (admin m)   where-    loop _ (Val x) = return x-    loop s (E u)   = handleRelay u (loop s) $+    loop _ (Pure x) = return x+    loop s (Free u)   = handleRelay u (loop s) $                           \(Fresh k) -> (loop $! succ s) (k s)

@@ -56,5 +56,5 @@ -- we only allow a single Lifted Monad. runLift :: (Monad m, Typeable1 m) => Eff (Lift m :> ()) w -> m w runLift m = loop (admin m) where- loop (Val x) = return x- loop (E u) = prjForce u $ \(Lift m' k) -> m' >>= loop . k+ loop (Pure x) = return x+ loop (Free u) = prjForce u $ \(Lift m' k) -> m' >>= loop . k

@@ -33,8 +33,8 @@       -> Eff r a local f m = do   e <- f <$> ask-  let loop (Val x) = return x-      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))+  let loop (Pure x) = return x+      loop (Free u) = interpose u loop (\(Reader k) -> loop (k e))   loop (admin m)  -- | Request the environment value using a transformation function.@@ -46,5 +46,5 @@ runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w runReader m e = loop (admin m)   where-    loop (Val x) = return x-    loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e))+    loop (Pure x) = return x+    loop (Free u) = handleRelay u loop (\(Reader k) -> loop (k e))

@@ -34,8 +34,8 @@       -> Eff r a local f m = do   e <- f <$> ask-  let loop (Val x) = return x-      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))+  let loop (Pure x) = return x+      loop (Free u) = interpose u loop (\(Reader k) -> loop (k e))   loop (admin m)  -- | Request the environment value using a transformation function.@@ -46,5 +46,5 @@ -- all Reader requests are fully handled. runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w runReader m !e = loop (admin m) where- loop (Val x) = return x- loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e))+ loop (Pure x) = return x+ loop (Free u) = handleRelay u loop (\(Reader k) -> loop (k e))

@@ -40,8 +40,8 @@          -> Eff (State s :> r) w  -- ^ Effect incorporating State          -> Eff r (s, w)          -- ^ Effect containing final state and a return value runState s0 = loop s0 . admin where- loop s (Val x) = return (s, x)- loop s (E u)   = handleRelay u (loop s) $+ loop s (Pure x) = return (s, x)+ loop s (Free u)   = handleRelay u (loop s) $                        \(State t k) -> let s' = t s                                        in loop s' (k s') 

@@ -53,8 +53,8 @@          -> Eff (State s :> r) w  -- ^ Effect incorporating State          -> Eff r (s, w)          -- ^ Effect containing final state and a return value runState s0 = loop s0 . admin where- loop !s (Val x) = return (s, x)- loop !s (E u)   = handleRelay u (loop s) $+ loop !s (Pure x) = return (s, x)+ loop !s (Free u)   = handleRelay u (loop s) $                        \(State t k) -> let s' = t s                                        in loop s' (k s') 

@@ -24,5 +24,5 @@ runTrace :: Eff (Trace :> ()) w -> IO w runTrace m = loop (admin m)   where-    loop (Val x) = return x-    loop (E u)   = prjForce u $ \(Trace s k) -> putStrLn s >> loop (k ())+    loop (Pure x) = return x+    loop (Free u)   = prjForce u $ \(Trace s k) -> putStrLn s >> loop (k ())

@@ -31,8 +31,8 @@ censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a censor f = loop . admin   where-    loop (Val x) = return x-    loop (E u) = interpose u loop+    loop (Pure x) = return x+    loop (Free u) = interpose u loop                $ \(Writer w v) -> tell (f w) >> loop v  -- | Handle Writer requests, using a user-provided function to accumulate values.@@ -41,8 +41,8 @@   where     first f (x, y) = (f x, y) -    loop (Val x) = return (b, x)-    loop (E u) = handleRelay u loop+    loop (Pure x) = return (b, x)+    loop (Free u) = handleRelay u loop                  $ \(Writer w v) -> first (accum w) <$> loop v  -- | Handle Writer requests by taking the first value provided.

@@ -32,8 +32,8 @@ censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a censor f = loop . admin   where-    loop (Val x) = return x-    loop (E u) = interpose u loop+    loop (Pure x) = return x+    loop (Free u) = interpose u loop                $ \(Writer w v) -> tell (f w) >> loop v  -- | Handle Writer requests, using a user-provided function to accumulate values.@@ -42,8 +42,8 @@   where     first f (x, y) = (f x, y) -    loop (Val x) = return (b, x)-    loop (E u) = handleRelay u loop+    loop (Pure x) = return (b, x)+    loop (Free u) = handleRelay u loop                  $ \(Writer w v) -> first (accum w) <$> loop v  -- | Handle Writer requests by taking the first value provided.

@@ -36,7 +36,7 @@  import Control.Applicative ((<$>)) import Data.Typeable-#if __GLASGOW_HASKELL__ >= 781+#if __GLASGOW_HASKELL__ >= 708 import Data.OpenUnion.Internal.OpenUnion2 #else import Data.OpenUnion.Internal.OpenUnion1

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-}@@ -23,6 +24,7 @@ -- NOTE: exposing the constructor below allows users to bypass the type -- system. See 'Data.OpenUnion.unsafeReUnion' for example. data Union r v = forall t. (Functor t, Typeable1 t) => Union (t v)+                 deriving Typeable  instance Functor (Union r) where     {-# INLINE fmap #-}@@ -31,3 +33,6 @@ -- | A sum data type, for composing effects infixr 1 :> data ((a :: * -> *) :> b)+#if __GLASGOW_HASKELL__ >= 708+  deriving Typeable+#endif

@@ -60,7 +60,7 @@            => [a]            -> Eff e ()     sumAll = mapM_ (LazyS.modify . (+))-    +     writeAndAdd :: (Member (LazyW.Writer Integer) e, Member (LazyS.State Integer) e)                 => [Integer]                 -> Eff e ()@@ -159,6 +159,24 @@     possiblyAmbiguous :: (Typeable1 m, Monad m, SetMember Lift (Lift m) r) => Eff r ()     possiblyAmbiguous = lift $ return () +#if __GLASGOW_HASKELL__ >= 708+testNestedEff :: Property+testNestedEff = forAll arbitrary (\x -> property (qu x == x))+  where+    qu :: Bool -> Bool+    qu x = run $ StrictR.runReader (readerAp x) readerId++    readerAp :: Bool -> Eff (StrictR.Reader (Eff (StrictR.Reader Bool :> ()) Bool) :> ()) Bool+    readerAp x = do+      f <- StrictR.ask+      return . run $ StrictR.runReader f x++    readerId :: Eff (StrictR.Reader Bool :> ()) Bool+    readerId = do+      x <- StrictR.ask+      return x+#endif+ tests =   [ testProperty "Documentation example." testDocs   , testProperty "Test Writer.Lazy.censor." testCensor@@ -171,4 +189,7 @@   , testCase "Test runFirstWriter laziness." testFirstWriterLaziness   , testCase "Test failure effect." testFailure   , testCase "Test lift building." testLift+#if __GLASGOW_HASKELL__ >= 708+  , testProperty "Test nested Eff." testNestedEff+#endif   ]