effects 0.2.1 → 0.2.2

raw patch · 23 files changed

+522/−543 lines, 23 filesdep ~containerssetup-changed

Dependency ranges changed: containers

Files

._LICENSE binary
._README.md binary
._effects.cabal binary
._examples.hs binary
LICENSE +31/−31
README.md +0/−28
Setup.lhs +2/−2
effects.cabal +41/−38
examples.hs +110/−109
src/Control/._Effects.hs binary
src/Control/Effects.hs +194/−194
src/Control/Effects/._Cont.hs binary
src/Control/Effects/._Either.hs binary
src/Control/Effects/._Error.hs binary
src/Control/Effects/._NonDet.hs binary
src/Control/Effects/._State.hs binary
src/Control/Effects/._Writer.hs binary
src/Control/Effects/Cont.hs +12/−12
src/Control/Effects/Either.hs +13/−13
src/Control/Effects/Error.hs +13/−13
src/Control/Effects/NonDet.hs +57/−54
src/Control/Effects/State.hs +34/−34
src/Control/Effects/Writer.hs +15/−15

− ._LICENSE

binary file changed (185 → absent bytes)

− ._README.md

binary file changed (187 → absent bytes)

− ._effects.cabal

binary file changed (186 → absent bytes)

− ._examples.hs

binary file changed (187 → absent bytes)

LICENSE view

@@ -1,31 +1,31 @@-Copyright Sjoerd Visscher 2011--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Sjoerd Visscher nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-+Copyright Sjoerd Visscher 2011
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Sjoerd Visscher nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

− README.md

@@ -1,28 +0,0 @@-Control.Effects-===============--Control.Effects is a Haskell library for programming with effects, like in the the [Eff language][Eff] by Andrej Bauer and Matija Pretnar. Effects can be used instead of monad transformers, they are designed to be easier to use and to define.--Installation---------------    cabal install effects--Using effects----------------Here's an example how to use the state effect from `Control.Effects.State`.--    example :: (Int, Int)-    example = run $ do-      with (ref 5) $ \x -> do-        with (ref 10) $ \y -> do-          x =: (+) <$> get x <*> get y-          y =: (+) <$> get x <*> get y-          (,) <$> get x <*> get y--Every instance of an effect is given a name (`x` and `y` in this example), which makes is possible to easily mix several instances of the same effect.--For more examples see [examples.hs](https://github.com/sjoerdvisscher/effects/blob/master/examples.hs).--[Eff]: http://math.andrej.com/category/programming/eff/?category_name=programming/eff

Setup.lhs view

@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple+#!/usr/bin/env runhaskell
+> import Distribution.Simple
 > main = defaultMain

effects.cabal view

@@ -1,39 +1,42 @@-name:                effects-version:             0.2.1-synopsis:            Computational Effects--description:         Control.Effects is a library for programming with effects, like in the the Eff language by -                     Andrej Bauer and Matija Pretnar. Effects can be used instead of monad transformers.-                     .-                     See the home page for some example code.--category:            Control, Monads-license:             BSD3-license-file:        LICENSE-author:              Sjoerd Visscher-maintainer:          sjoerd@w3future.com-stability:           experimental-homepage:            http://github.com/sjoerdvisscher/effects-bug-reports:         http://github.com/sjoerdvisscher/effects/issues--build-type:          Simple-cabal-version:       >= 1.6--Library-  HS-Source-Dirs:      src-  build-depends:       base >= 3 && < 5, -                       containers  >= 0.4 && < 0.5,-                       newtype >= 0.2 && < 0.3,-                       void-  exposed-modules:     -    Control.Effects-    Control.Effects.Cont-    Control.Effects.Either-    Control.Effects.Error-    Control.Effects.NonDet-    Control.Effects.State-    Control.Effects.Writer-    -source-repository head-  type:     git+name:                effects
+version:             0.2.2
+synopsis:            Computational Effects
+
+description:         Control.Effects is a library for programming with effects, like in the the Eff language by 
+                     Andrej Bauer and Matija Pretnar. Effects can be used instead of monad transformers.
+                     .
+                     See the home page for some example code.
+
+category:            Control, Monads
+license:             BSD3
+license-file:        LICENSE
+author:              Sjoerd Visscher
+maintainer:          sjoerd@w3future.com
+stability:           experimental
+homepage:            http://github.com/sjoerdvisscher/effects
+bug-reports:         http://github.com/sjoerdvisscher/effects/issues
+
+build-type:          Simple
+cabal-version:       >= 1.6
+
+Extra-Source-Files:
+  examples.hs
+
+Library
+  HS-Source-Dirs:      src
+  build-depends:       base >= 3 && < 5, 
+                       containers  >= 0.4 && < 0.6,
+                       newtype >= 0.2 && < 0.3,
+                       void
+  exposed-modules:     
+    Control.Effects
+    Control.Effects.Cont
+    Control.Effects.Either
+    Control.Effects.Error
+    Control.Effects.NonDet
+    Control.Effects.State
+    Control.Effects.Writer
+    
+source-repository head
+  type:     git
   location: git://github.com/sjoerdvisscher/effects.git

examples.hs view

@@ -1,109 +1,110 @@-module Main where--import Control.Effects-import Control.Effects.Cont-import Control.Effects.Either-import Control.Effects.Error-import Control.Effects.State-import Control.Effects.Writer-import Control.Effects.NonDet--import qualified Data.Set as Set-import Data.Monoid-import Control.Applicative---testIO :: IO ()-testIO = runBase $ do-  base $ putStrLn "What's your name?"-  name <- base getLine-  base $ putStrLn $ "Hello, " ++ name--testRefIO :: IO ()-testRefIO = runBase $ do-  with (ref 5) $ \x -> do-    val <- get x-    base $ print val--testRef :: (Int, Int)-testRef = run $ do-  with (ref 5) $ \x -> do-    with (ref 10) $ \y -> do-      x =: (+) <$> get x <*> get y-      y =: (+) <$> get x <*> get y-      (,) <$> get x <*> get y-      --testWriter :: (String, (String, Int))-testWriter = run $ do-  with writer $ \w1 -> do-    with writer $ \w2 -> do-      tell w1 "123"-      tell w2 "abc"-      tell w1 "456"-      tell w2 "def"-      return 1---testSet :: Set.Set Int-testSet = run $-  with set $ \s -> do-    x <- choose s [1, 2]-    y <- choose s [1, 2]-    z <- choose s [1, 2]-    return $ x * x - y * z * x + z * z * z - y * y * x--testAccumulate :: Bool-testAccumulate = run $-  with (accumulate Any) $ \s -> do-    x <- choose s [1, 2]-    y <- choose s [1, 2]-    z <- choose s [1, 2]-    return $ x * x - y * z * x + z * z * z - y * y * x == 0---testDfs :: [Int] -> [(Int, Int, Int)]-testDfs = run . with (dfs return) . triples--testBfs :: [Int] -> [(Int, Int, Int)]-testBfs = run . with (bfs return) . triples--triples :: (Num a, Monoid e, AutoLift e m n) => [a] -> Effect e m -> n (a, a, a)-triples range s = do-  x <- choose s range-  y <- choose s range-  z <- choose s range-  if x*x + y*y == z*z then return (x,y,z) else choose s []---testError :: IO ()-testError = runBase $ do-  with (catchError (\e -> base $ putStrLn ("Error: " ++ e))) $ \c -> do-    base $ putStrLn "before"-    throwError c "123"-    base $ putStrLn "after"-  --testEither :: IO ()-testEither = runBase $ do-  with (catchEither (\e -> base $ putStrLn ("Error: " ++ e))) $ \c -> do-    base $ putStrLn "before"-    throwEither c "123"-    base $ putStrLn "after"---testReset1 :: Int-testReset1 = run $ do-  with reset $ \r -> do-    x <- shift r (\k -> k (k (k (return 7))))-    return $ x * 2 + 1--testReset2 :: IO ()-testReset2 = runBase $ do-  r <- with reset $ \promptA -> do-    base $ putStrLn "Batman"-    with reset $ \promptB -> do-      shift promptB $ \k -> k (k (shift promptA $ \l -> l (l (return ()))))-      base $ putStrLn "Robin"-    base $ putStrLn "Cat woman"-  base $ print r+module Main where
+
+import Control.Effects
+import Control.Effects.Cont
+import Control.Effects.Either
+import Control.Effects.Error
+import Control.Effects.State
+import Control.Effects.Writer
+import Control.Effects.NonDet
+
+import qualified Data.Set as Set
+import Data.Monoid
+import Control.Applicative
+
+
+testIO :: IO ()
+testIO = runBase $ do
+  base $ putStrLn "What's your name?"
+  name <- base getLine
+  base $ putStrLn $ "Hello, " ++ name
+
+testRefIO :: IO ()
+testRefIO = runBase $ do
+  with (ref 5) $ \x -> do
+    val <- get x
+    base $ print val
+
+testRef :: (Int, Int)
+testRef = run $ do
+  with (ref 5) $ \x -> do
+    with (ref 10) $ \y -> do
+      x =: (+) <$> get x <*> get y
+      y =: (+) <$> get x <*> get y
+      (,) <$> get x <*> get y
+      
+
+testWriter :: (String, (String, Int))
+testWriter = run $ do
+  with writer $ \w1 -> do
+    with writer $ \w2 -> do
+      tell w1 "123"
+      tell w2 "abc"
+      tell w1 "456"
+      tell w2 "def"
+      return 1
+
+
+testSet :: Set.Set Int
+testSet = run $
+  with set $ \s -> do
+    x <- choose s [1, 2]
+    y <- choose s [1, 2]
+    z <- choose s [1, 2]
+    return $ x * x - y * z * x + z * z * z - y * y * x
+
+testAccumulate :: Bool
+testAccumulate = run $
+  with (accumulate Any) $ \s -> do
+    x <- choose s [1, 2]
+    y <- choose s [1, 2]
+    z <- choose s [1, 2]
+    return $ x * x - y * z * x + z * z * z - y * y * x == 0
+
+
+testDfs :: [Int] -> [(Int, Int, Int)]
+testDfs = run . with (dfs return) . triples
+
+testBfs :: [Int] -> [(Int, Int, Int)]
+testBfs = run . with (bfs return) . triples
+
+triples :: (Num a, Monoid e, AutoLift e m n) => [a] -> Effect e m -> n (a, a, a)
+triples range s = do
+  x <- choose s range
+  y <- choose s range
+  z <- choose s range
+  guard s $ x*x + y*y == z*z
+  return (x,y,z)
+
+
+testError :: IO ()
+testError = runBase $ do
+  with (catchError (\e -> base $ putStrLn ("Error: " ++ e))) $ \c -> do
+    base $ putStrLn "before"
+    throwError c "123"
+    base $ putStrLn "after"
+  
+
+testEither :: IO ()
+testEither = runBase $ do
+  with (catchEither (\e -> base $ putStrLn ("Error: " ++ e))) $ \c -> do
+    base $ putStrLn "before"
+    throwEither c "123"
+    base $ putStrLn "after"
+
+
+testReset1 :: Int
+testReset1 = run $ do
+  with reset $ \r -> do
+    x <- shift r (\k -> k (k (k (return 7))))
+    return $ x * 2 + 1
+
+testReset2 :: IO ()
+testReset2 = runBase $ do
+  r <- with reset $ \promptA -> do
+    base $ putStrLn "Batman"
+    with reset $ \promptB -> do
+      shift promptB $ \k -> k (k (shift promptA $ \l -> l (l (return ()))))
+      base $ putStrLn "Robin"
+    base $ putStrLn "Cat woman"
+  base $ print r

− src/Control/._Effects.hs

binary file changed (187 → absent bytes)

src/Control/Effects.hs view

@@ -1,194 +1,194 @@-{-# LANGUAGE MultiParamTypeClasses, KindSignatures, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}-module Control.Effects (--  -- * Running effects-  -- $rundoc-    with-  , run-  -- * Defining effects  -  -- $defdoc-  , Handler(..)-  , operation-  -- * Base monad-  -- $basedoc-  , runBase-  , base-  -- * Effects machinery-  -- $macdoc-  , Layer(..)-  , Base(..)-  , Pure(..)-  , Effect-  , AutoLift-  , AutoLiftBase--) where--import Control.Applicative-import Control.Monad-import Data.Monoid---- $rundoc--- Here's an example how to use the state effect from 'Control.Effects.State':------ > example :: Int--- > example = run $ do--- >   with (ref 10) $ \u -> do--- >     val <- get u--- >     put u (val + 5)--- >     get u---- | @with@ takes a handler and creates a new effect instance.---   The @Effect@ is passed on to a function which can use it to do operations with it.-with :: Monad m => Handler e r m a -> (Effect e m -> Layer e m a) -> m r-with h f = runLayer (f Effect) (ret h) >>= fin h---- | Unwrap the result of the top-level effect.-run :: Base Pure a -> a-run (Base (Pure a)) = a----- $defdoc--- Here's and example how to define the state effect from 'Control.Effects.Writer':------ > writer :: (Monad m, Monoid w) => Handler (w, a) (w, a) m a--- > writer = Handler--- >   { ret = \a -> return (mempty, a)--- >   , fin = return--- >   }--- > --- > tell :: (AutoLift (w, r) m n, Monoid w) => Effect (w, r) m -> w -> n ()--- > tell p v = operation p $ \k -> do--- >   (w, r) <- k ()--- >   return (mappend v w, r)---- | A @Handler e r m a@ is a handler of effects with type @e@. ---   The @ret@ field provides a function to lift pure values into the effect.---   The @fin@ field provides a function to extract a final value of type @r@ from the effect.---   The parameter @m@ should normally be left polymorphic, it's the monad that handles the other effects.-data Handler e r m a = Handler-  { ret :: a -> m e-  , fin :: e -> m r-  }---- | @operation@ takes an effect identifier generated by `with` and a function which takes a continuation as parameter.---   The result is auto-lifted so it can be used inside any other effect.-operation :: AutoLift e m n => Effect e m -> ((a -> m e) -> m e) -> n a-operation = operation'----- $basedoc--- The effects are layered on top of a base monad. Here's an example how to use `IO` as a base monad:--- --- > exampleIO :: IO ()--- > exampleIO = runBase $ do--- >   with (ref 5) $ \x -> do--- >     val <- get x--- >     base $ print val---- | @base@ takes a computation in the base monad and auto-lifts it so it can be used inside any effect.-base :: AutoLiftBase m n => m a -> n a-base = base'---- | Unwrap the result of a computation using a base monad.-runBase :: Base m a -> m a-runBase (Base m) = m----- $macdoc--- Effects are layered in a stack on top of a base monad. Just like with monad transformers, operations lower in the stack--- need to be lifted to be able to be used together with operations higher in the stack. But as there are only two  monads--- in play, `Layer` and `Base`, and because each operation is identified with exactly one layer using the `Effect` type,--- lifting can be done automatically.------ The following types and classes show up in the type signatures. The compiler should be able to infer them for you.---- | @Layer e m@ is a monad that adds an effect @e@ to the underlying monad @m@.---   (It is the continuation monad transformer with a friendlier name.)-newtype Layer e m a = Layer { runLayer :: (a -> m e) -> m e }--instance Functor (Layer e m) where-  fmap f m = Layer $ \k -> runLayer m (k . f)--instance Applicative (Layer e m) where-  pure a   = Layer $ \k -> k a-  m <*> v  = Layer $ \k -> runLayer m (\f -> runLayer v (k . f))--instance (Monoid e, Applicative m) => Alternative (Layer e m) where-  empty = Layer $ \_ -> pure mempty-  l <|> r = Layer $ \k -> mappend <$> runLayer l k <*> runLayer r k--instance Monad (Layer e m) where-  return a = Layer $ \k -> k a-  m >>= f  = Layer $ \k -> runLayer m (\a -> runLayer (f a) k)--instance (Monoid e, Applicative m) => MonadPlus (Layer e m) where-  mzero = empty-  mplus = (<|>)----- | @Pure@ is the identity monad and is used when no other base monad is needed.-newtype Pure a = Pure a--instance Functor Pure where-  fmap f (Pure a) = Pure (f a)--instance Applicative Pure where-  pure = Pure-  Pure f <*> Pure a = Pure (f a)  -  -instance Monad Pure where-  return = Pure-  Pure a >>= f = f a----- | @Base m@ is a newtype wrapper around a monadic computation.-newtype Base m a = Base (m a)--instance Functor m => Functor (Base m) where-  fmap f (Base m) = Base (fmap f m)--instance Applicative m => Applicative (Base m) where-  pure = Base . pure-  Base m <*> Base v = Base (m <*> v)-  -instance Monad m => Monad (Base m) where-  return = Base . return-  Base m >>= f = Base $ m >>= runBase . f---- | @Effect e m@ is a proxy for the type checker to be able to work with multiple effects at the same time.-data Effect e (m :: * -> *) = Effect---class (Monad m, Monad n) => AutoLift e m n where-  operation' :: Effect e m -> ((a -> m e) -> m e) -> n a--instance (Monad m, Monad n, AutoLiftInternal (Layer e m) (Base    n) (Layer e m) (Base    n)) => AutoLift e m (Base    n) where-  operation' _ f = autolift (Proxy :: Proxy (Layer e m)) (Proxy :: Proxy (Base    n)) (Layer f)-instance (Monad m, Monad n, AutoLiftInternal (Layer e m) (Layer d n) (Layer e m) (Layer d n)) => AutoLift e m (Layer d n) where-  operation' _ f = autolift (Proxy :: Proxy (Layer e m)) (Proxy :: Proxy (Layer d n)) (Layer f)---class (Monad m, Monad n) => AutoLiftBase m n where-  base' :: m a -> n a--instance (Monad m, Monad n, AutoLiftInternal (Base    m) (Base    n) (Base    m) (Base    n)) => AutoLiftBase m (Base    n) where-  base' m        = autolift (Proxy :: Proxy (Base    m)) (Proxy :: Proxy (Base    n)) (Base m)-instance (Monad m, Monad n, AutoLiftInternal (Base    m) (Layer e n) (Base    m) (Layer e n)) => AutoLiftBase m (Layer e n) where-  base' m        = autolift (Proxy :: Proxy (Base    m)) (Proxy :: Proxy (Layer e n)) (Base m)---data Proxy (m :: * -> *) = Proxy--class (Monad m1, Monad m2) =>  AutoLiftInternal m1 m2 n1 n2 where-  autolift :: Proxy n1 -> Proxy n2 -> m1 a -> m2 a--pre :: Proxy (Layer r m) -> Proxy m-pre Proxy = Proxy--instance (Monad m)                             => AutoLiftInternal m           m   (Base    n)  (Base    n)  where-  autolift Proxy Proxy = id-instance (AutoLiftInternal m1 m2 (Base n1) n2) => AutoLiftInternal m1 (Layer r m2) (Base    n1) (Layer s n2) where-  autolift p1 p2 = Layer . (>>=) . autolift p1 (pre p2)-instance (AutoLiftInternal m1 m2       n1  n2) => AutoLiftInternal m1          m2  (Layer r n1) (Layer s n2) where-  autolift p1 p2 = autolift (pre p1) (pre p2)+{-# LANGUAGE MultiParamTypeClasses, KindSignatures, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+module Control.Effects (
+
+  -- * Running effects
+  -- $rundoc
+    with
+  , run
+  -- * Defining effects  
+  -- $defdoc
+  , Handler(..)
+  , operation
+  -- * Base monad
+  -- $basedoc
+  , runBase
+  , base
+  -- * Effects machinery
+  -- $macdoc
+  , Layer(..)
+  , Base(..)
+  , Pure(..)
+  , Effect
+  , AutoLift
+  , AutoLiftBase
+
+) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+
+-- $rundoc
+-- Here's an example how to use the state effect from 'Control.Effects.State':
+--
+-- > example :: Int
+-- > example = run $ do
+-- >   with (ref 10) $ \u -> do
+-- >     val <- get u
+-- >     put u (val + 5)
+-- >     get u
+
+-- | @with@ takes a handler and creates a new effect instance.
+--   The @Effect@ is passed on to a function which can use it to do operations with it.
+with :: Monad m => Handler e r m a -> (Effect e m -> Layer e m a) -> m r
+with h f = runLayer (f Effect) (ret h) >>= fin h
+
+-- | Unwrap the result of the top-level effect.
+run :: Base Pure a -> a
+run (Base (Pure a)) = a
+
+
+-- $defdoc
+-- Here's and example how to define the state effect from 'Control.Effects.Writer':
+--
+-- > writer :: (Monad m, Monoid w) => Handler (w, a) (w, a) m a
+-- > writer = Handler
+-- >   { ret = \a -> return (mempty, a)
+-- >   , fin = return
+-- >   }
+-- > 
+-- > tell :: (AutoLift (w, r) m n, Monoid w) => Effect (w, r) m -> w -> n ()
+-- > tell p v = operation p $ \k -> do
+-- >   (w, r) <- k ()
+-- >   return (mappend v w, r)
+
+-- | A @Handler e r m a@ is a handler of effects with type @e@. 
+--   The @ret@ field provides a function to lift pure values into the effect.
+--   The @fin@ field provides a function to extract a final value of type @r@ from the effect.
+--   The parameter @m@ should normally be left polymorphic, it's the monad that handles the other effects.
+data Handler e r m a = Handler
+  { ret :: a -> m e
+  , fin :: e -> m r
+  }
+
+-- | @operation@ takes an effect identifier generated by `with` and a function which takes a continuation as parameter.
+--   The result is auto-lifted so it can be used inside any other effect.
+operation :: AutoLift e m n => Effect e m -> ((a -> m e) -> m e) -> n a
+operation = operation'
+
+
+-- $basedoc
+-- The effects are layered on top of a base monad. Here's an example how to use `IO` as a base monad:
+-- 
+-- > exampleIO :: IO ()
+-- > exampleIO = runBase $ do
+-- >   with (ref 5) $ \x -> do
+-- >     val <- get x
+-- >     base $ print val
+
+-- | @base@ takes a computation in the base monad and auto-lifts it so it can be used inside any effect.
+base :: AutoLiftBase m n => m a -> n a
+base = base'
+
+-- | Unwrap the result of a computation using a base monad.
+runBase :: Base m a -> m a
+runBase (Base m) = m
+
+
+-- $macdoc
+-- Effects are layered in a stack on top of a base monad. Just like with monad transformers, operations lower in the stack
+-- need to be lifted to be able to be used together with operations higher in the stack. But as there are only two  monads
+-- in play, `Layer` and `Base`, and because each operation is identified with exactly one layer using the `Effect` type,
+-- lifting can be done automatically.
+--
+-- The following types and classes show up in the type signatures. The compiler should be able to infer them for you.
+
+-- | @Layer e m@ is a monad that adds an effect @e@ to the underlying monad @m@.
+--   (It is the continuation monad transformer with a friendlier name.)
+newtype Layer e m a = Layer { runLayer :: (a -> m e) -> m e }
+
+instance Functor (Layer e m) where
+  fmap f m = Layer $ \k -> runLayer m (k . f)
+
+instance Applicative (Layer e m) where
+  pure a   = Layer $ \k -> k a
+  m <*> v  = Layer $ \k -> runLayer m (\f -> runLayer v (k . f))
+
+instance (Monoid e, Applicative m) => Alternative (Layer e m) where
+  empty = Layer $ \_ -> pure mempty
+  l <|> r = Layer $ \k -> mappend <$> runLayer l k <*> runLayer r k
+
+instance Monad (Layer e m) where
+  return a = Layer $ \k -> k a
+  m >>= f  = Layer $ \k -> runLayer m (\a -> runLayer (f a) k)
+
+instance (Monoid e, Applicative m) => MonadPlus (Layer e m) where
+  mzero = empty
+  mplus = (<|>)
+
+
+-- | @Pure@ is the identity monad and is used when no other base monad is needed.
+newtype Pure a = Pure a
+
+instance Functor Pure where
+  fmap f (Pure a) = Pure (f a)
+
+instance Applicative Pure where
+  pure = Pure
+  Pure f <*> Pure a = Pure (f a)  
+  
+instance Monad Pure where
+  return = Pure
+  Pure a >>= f = f a
+
+
+-- | @Base m@ is a newtype wrapper around a monadic computation.
+newtype Base m a = Base (m a)
+
+instance Functor m => Functor (Base m) where
+  fmap f (Base m) = Base (fmap f m)
+
+instance Applicative m => Applicative (Base m) where
+  pure = Base . pure
+  Base m <*> Base v = Base (m <*> v)
+  
+instance Monad m => Monad (Base m) where
+  return = Base . return
+  Base m >>= f = Base $ m >>= runBase . f
+
+-- | @Effect e m@ is a proxy for the type checker to be able to work with multiple effects at the same time.
+data Effect e (m :: * -> *) = Effect
+
+
+class (Applicative m, Applicative n, Monad m, Monad n) => AutoLift e m n where
+  operation' :: Effect e m -> ((a -> m e) -> m e) -> n a
+
+instance (Applicative m, Applicative n, Monad m, Monad n, AutoLiftInternal (Layer e m) (Base    n) (Layer e m) (Base    n)) => AutoLift e m (Base    n) where
+  operation' _ f = autolift (Proxy :: Proxy (Layer e m)) (Proxy :: Proxy (Base    n)) (Layer f)
+instance (Applicative m, Applicative n, Monad m, Monad n, AutoLiftInternal (Layer e m) (Layer d n) (Layer e m) (Layer d n)) => AutoLift e m (Layer d n) where
+  operation' _ f = autolift (Proxy :: Proxy (Layer e m)) (Proxy :: Proxy (Layer d n)) (Layer f)
+
+
+class (Applicative m, Applicative n, Monad m, Monad n) => AutoLiftBase m n where
+  base' :: m a -> n a
+
+instance (Applicative m, Applicative n, Monad m, Monad n, AutoLiftInternal (Base    m) (Base    n) (Base    m) (Base    n)) => AutoLiftBase m (Base    n) where
+  base' m        = autolift (Proxy :: Proxy (Base    m)) (Proxy :: Proxy (Base    n)) (Base m)
+instance (Applicative m, Applicative n, Monad m, Monad n, AutoLiftInternal (Base    m) (Layer e n) (Base    m) (Layer e n)) => AutoLiftBase m (Layer e n) where
+  base' m        = autolift (Proxy :: Proxy (Base    m)) (Proxy :: Proxy (Layer e n)) (Base m)
+
+
+data Proxy (m :: * -> *) = Proxy
+
+class (Applicative m1, Applicative m2, Monad m1, Monad m2) =>  AutoLiftInternal m1 m2 n1 n2 where
+  autolift :: Proxy n1 -> Proxy n2 -> m1 a -> m2 a
+
+pre :: Proxy (Layer r m) -> Proxy m
+pre Proxy = Proxy
+
+instance (Applicative m, Monad m)              => AutoLiftInternal m           m   (Base    n)  (Base    n)  where
+  autolift Proxy Proxy = id
+instance (AutoLiftInternal m1 m2 (Base n1) n2) => AutoLiftInternal m1 (Layer r m2) (Base    n1) (Layer s n2) where
+  autolift p1 p2 = Layer . (>>=) . autolift p1 (pre p2)
+instance (AutoLiftInternal m1 m2       n1  n2) => AutoLiftInternal m1          m2  (Layer r n1) (Layer s n2) where
+  autolift p1 p2 = autolift (pre p1) (pre p2)

− src/Control/Effects/._Cont.hs

binary file changed (186 → absent bytes)

− src/Control/Effects/._Either.hs

binary file changed (186 → absent bytes)

− src/Control/Effects/._Error.hs

binary file changed (186 → absent bytes)

− src/Control/Effects/._NonDet.hs

binary file changed (186 → absent bytes)

− src/Control/Effects/._State.hs

binary file changed (186 → absent bytes)

− src/Control/Effects/._Writer.hs

binary file changed (186 → absent bytes)

src/Control/Effects/Cont.hs view

@@ -1,13 +1,13 @@-{-# LANGUAGE FlexibleContexts #-}-module Control.Effects.Cont where--import Control.Effects--shift :: AutoLift r m n => Effect r m -> ((m a -> m r) -> m r) -> n a-shift p c = operation p $ \k -> c (>>= k)--reset :: Monad m => Handler a a m a-reset = Handler-  { ret = return-  , fin = return+{-# LANGUAGE FlexibleContexts #-}
+module Control.Effects.Cont where
+
+import Control.Effects
+
+shift :: AutoLift r m n => Effect r m -> ((m a -> m r) -> m r) -> n a
+shift p c = operation p $ \k -> c (>>= k)
+
+reset :: Monad m => Handler a a m a
+reset = Handler
+  { ret = return
+  , fin = return
   }

src/Control/Effects/Either.hs view

@@ -1,14 +1,14 @@-{-# LANGUAGE FlexibleContexts #-}-module Control.Effects.Either where--import Control.Effects-import Data.Void--throwEither :: AutoLift (Either e r) m n => Effect (Either e r) m -> e -> n Void-throwEither p e = operation p $ \_ -> return $ Left e--catchEither :: Monad m => (e -> m a) -> Handler (Either e a) a m a-catchEither h = Handler-  { ret = return . return-  , fin = either h return+{-# LANGUAGE FlexibleContexts #-}
+module Control.Effects.Either where
+
+import Control.Effects
+import Data.Void
+
+throwEither :: AutoLift (Either e r) m n => Effect (Either e r) m -> e -> n Void
+throwEither p e = operation p $ \_ -> return $ Left e
+
+catchEither :: Monad m => (e -> m a) -> Handler (Either e a) a m a
+catchEither h = Handler
+  { ret = return . return
+  , fin = either h return
   }

src/Control/Effects/Error.hs view

@@ -1,14 +1,14 @@-{-# LANGUAGE FlexibleContexts #-}-module Control.Effects.Error where--import Control.Effects-import Data.Void--throwError :: AutoLift ((e -> m r) -> m r) m n => Effect ((e -> m r) -> m r) m -> e -> n Void-throwError p e = operation p $ \_ -> return $ \h -> h e--catchError :: Monad m => (e -> m a) -> Handler ((e -> m a) -> m a) a m a-catchError h = Handler-  { ret = return . return . return-  , fin = \f -> f h+{-# LANGUAGE FlexibleContexts #-}
+module Control.Effects.Error where
+
+import Control.Effects
+import Data.Void
+
+throwError :: AutoLift ((e -> m r) -> m r) m n => Effect ((e -> m r) -> m r) m -> e -> n Void
+throwError p e = operation p $ \_ -> return $ \h -> h e
+
+catchError :: Monad m => (e -> m a) -> Handler ((e -> m a) -> m a) a m a
+catchError h = Handler
+  { ret = return . return . return
+  , fin = \f -> f h
   }

src/Control/Effects/NonDet.hs view

@@ -1,55 +1,58 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}-module Control.Effects.NonDet (choose, dfs, set, alternatives, accumulate, bfs) where--import Control.Effects-import qualified Data.Set as Set-import Prelude hiding (foldr)-import Data.Foldable-import Data.Monoid-import Control.Applicative-import Control.Monad-import Control.Newtype--instance (Monad m, Monoid r) => Monoid (WrappedMonad m r) where-  mempty                              = WrapMonad $ return mempty-  mappend (WrapMonad a) (WrapMonad b) = WrapMonad $ liftM2 mappend a b--newtype WrappedAlt f a = WrapAlt (f a)-instance Newtype (WrappedAlt m a) (m a) where-  pack = WrapAlt-  unpack (WrapAlt a) = a-instance Alternative f => Monoid (WrappedAlt f a) where-  mempty                          = WrapAlt empty-  mappend (WrapAlt a) (WrapAlt b) = WrapAlt $ a <|> b--choose :: (AutoLift r m n, Monoid r, Foldable f) => Effect r m -> f a -> n a-choose p as = operation p $ \k -> ala' WrapMonad foldMap k as--dfs :: (Monad m, Monoid r) => (a -> r) -> Handler r r m a-dfs f = Handler-  { ret = return . f-  , fin = return-  }--set :: (Monad m, Ord a) => Handler (Set.Set a) (Set.Set a) m a-set = dfs Set.singleton--alternatives :: (Monad m, Alternative f) => Handler (WrappedAlt f a) (f a) m a-alternatives = accumulate (WrapAlt . pure)--accumulate :: (Monad m, Newtype n o) => (a -> n) -> Handler n o m a-accumulate f = Handler-  { ret = return . f-  , fin = return . unpack-  }--newtype BFS r = BFS { unBFS :: Int -> Maybe r }-instance Monoid r => Monoid (BFS r) where-  mempty                = BFS $ \d -> if d == 0 then Just mempty else Nothing-  BFS f `mappend` BFS g = BFS $ \d -> if d == 0 then f d else f d `mappend` g (d - 1)-instance Monoid r => Newtype (BFS r) r where-  pack r                = BFS $ \d -> if d == 0 then Just r else Nothing-  unpack (BFS f)        = loop 0 where loop d = maybe mempty (`mappend` loop (d + 1)) (f d)--bfs :: (Monad m, Monoid r) => (a -> r) -> Handler (BFS r) r m a+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
+module Control.Effects.NonDet (choose, guard, dfs, set, alternatives, accumulate, bfs) where
+
+import Control.Effects
+import qualified Data.Set as Set
+import Prelude hiding (foldr)
+import Data.Foldable
+import Data.Monoid
+import Control.Applicative
+import Control.Newtype
+
+instance (Applicative m, Monoid r) => Monoid (WrappedMonad m r) where
+  mempty                              = WrapMonad $ pure mempty
+  mappend (WrapMonad a) (WrapMonad b) = WrapMonad $ liftA2 mappend a b
+
+newtype WrappedAlt f a = WrapAlt (f a)
+instance Newtype (WrappedAlt m a) (m a) where
+  pack = WrapAlt
+  unpack (WrapAlt a) = a
+instance Alternative f => Monoid (WrappedAlt f a) where
+  mempty                          = WrapAlt empty
+  mappend (WrapAlt a) (WrapAlt b) = WrapAlt $ a <|> b
+
+choose :: (AutoLift r m n, Monoid r, Foldable f) => Effect r m -> f a -> n a
+choose p as = operation p $ \k -> ala' WrapMonad foldMap k as
+
+guard :: (Monoid r, AutoLift r m n) => Effect r m -> Bool -> n ()
+guard _ True = return ()
+guard p False = choose p []
+
+dfs :: (Monad m, Monoid r) => (a -> r) -> Handler r r m a
+dfs f = Handler
+  { ret = return . f
+  , fin = return
+  }
+
+set :: (Monad m, Ord a) => Handler (Set.Set a) (Set.Set a) m a
+set = dfs Set.singleton
+
+alternatives :: (Monad m, Alternative f) => Handler (WrappedAlt f a) (f a) m a
+alternatives = accumulate (WrapAlt . pure)
+
+accumulate :: (Monad m, Newtype n o) => (a -> n) -> Handler n o m a
+accumulate f = Handler
+  { ret = return . f
+  , fin = return . unpack
+  }
+
+newtype BFS r = BFS (Int -> Maybe r)
+instance Monoid r => Monoid (BFS r) where
+  mempty                = BFS $ \d -> if d == 0 then Just mempty else Nothing
+  BFS f `mappend` BFS g = BFS $ \d -> if d == 0 then f d else f d `mappend` g (d - 1)
+instance Monoid r => Newtype (BFS r) r where
+  pack r                = BFS $ \d -> if d == 0 then Just r else Nothing
+  unpack (BFS f)        = loop 0 where loop d = maybe mempty (`mappend` loop (d + 1)) (f d)
+
+bfs :: (Monad m, Monoid r) => (a -> r) -> Handler (BFS r) r m a
 bfs f = accumulate (pack . f)

src/Control/Effects/State.hs view

@@ -1,35 +1,35 @@-{-# LANGUAGE FlexibleContexts #-}-module Control.Effects.State where--import Control.Effects--type State s m a = s -> m a--get :: AutoLift (State s m a) m n => Effect (State s m a) m -> n s-get p = operation p $ \k -> return $ \s -> do r <- k s; r s--put :: AutoLift (State s m a) m n => Effect (State s m a) m -> s -> n ()-put p s = operation p $ \k -> return $ \_ -> do r <- k (); r s--infixr 3 =:-(=:) :: AutoLift (State s m a) m n => Effect (State s m a) m -> n s -> n ()-p =: m = m >>= put p--modify :: AutoLift (State s m a) m n => Effect (State s m a) m -> (s -> s) -> n ()-modify p f = do-  v <- get p-  put p (f v)--local :: AutoLift (State s m a) m n => Effect (State s m a) m -> (s -> s) -> n b -> n b-local p f m = do-  v <- get p-  put p (f v)-  r <- m-  put p v-  return r--ref :: Monad m => s -> Handler (State s m a) a m a-ref s_init = Handler-  { ret = return . return . return-  , fin = \f -> f s_init+{-# LANGUAGE FlexibleContexts #-}
+module Control.Effects.State where
+
+import Control.Effects
+
+type State s m a = s -> m a
+
+get :: AutoLift (State s m a) m n => Effect (State s m a) m -> n s
+get p = operation p $ \k -> return $ \s -> do r <- k s; r s
+
+put :: AutoLift (State s m a) m n => Effect (State s m a) m -> s -> n ()
+put p s = operation p $ \k -> return $ \_ -> do r <- k (); r s
+
+infixr 3 =:
+(=:) :: AutoLift (State s m a) m n => Effect (State s m a) m -> n s -> n ()
+p =: m = m >>= put p
+
+modify :: AutoLift (State s m a) m n => Effect (State s m a) m -> (s -> s) -> n ()
+modify p f = do
+  v <- get p
+  put p (f v)
+
+local :: AutoLift (State s m a) m n => Effect (State s m a) m -> (s -> s) -> n b -> n b
+local p f m = do
+  v <- get p
+  put p (f v)
+  r <- m
+  put p v
+  return r
+
+ref :: Monad m => s -> Handler (State s m a) a m a
+ref s_init = Handler
+  { ret = return . return . return
+  , fin = \f -> f s_init
   }

src/Control/Effects/Writer.hs view

@@ -1,16 +1,16 @@-{-# LANGUAGE FlexibleContexts #-}-module Control.Effects.Writer where--import Control.Effects-import Data.Monoid--tell :: (AutoLift (w, r) m n, Monoid w) => Effect (w, r) m -> w -> n ()-tell p v = operation p $ \k -> do-  ~(w, r) <- k ()-  return (mappend v w, r)--writer :: (Monad m, Monoid w) => Handler (w, a) (w, a) m a-writer = Handler-  { ret = \a -> return (mempty, a)-  , fin = return+{-# LANGUAGE FlexibleContexts #-}
+module Control.Effects.Writer where
+
+import Control.Effects
+import Data.Monoid
+
+tell :: (AutoLift (w, r) m n, Monoid w) => Effect (w, r) m -> w -> n ()
+tell p v = operation p $ \k -> do
+  ~(w, r) <- k ()
+  return (mappend v w, r)
+
+writer :: (Monad m, Monoid w) => Handler (w, a) (w, a) m a
+writer = Handler
+  { ret = \a -> return (mempty, a)
+  , fin = return
   }