diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,312 @@ + +# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg), ![GHC](https://img.shields.io/badge/GHC-8.2.2%20%7C%208.4.4%20%7C%208.6.3-blue.svg)) + +[![Build Status](https://travis-ci.org/suhailshergill/extensible-effects.svg?branch=master)](https://travis-ci.org/suhailshergill/extensible-effects) +[![Join the chat at https://gitter.im/suhailshergill/extensible-effects](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/suhailshergill/extensible-effects?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +[![Stories in Ready](https://badge.waffle.io/suhailshergill/extensible-effects.png?label=ready&title=Ready)](http://waffle.io/suhailshergill/extensible-effects) +[![Stories in progress](https://badge.waffle.io/suhailshergill/extensible-effects.png?label=in%20progress&title=In%20progress)](http://waffle.io/suhailshergill/extensible-effects) + +*Implement effectful computations in a modular way!* + +The main monad of this package is `Eff` from `Control.Eff`. +`Eff r a` is parameterized by the effect-list `r` and the monadic-result type +`a` similar to other monads. +It is the intention that all other monadic computations can be replaced by the +use of `Eff`. + +In case you know monad transformers or `mtl`: +This library provides only one monad that includes all your effects instead of +layering different transformers. +It is not necessary to lift the computations through a monad stack. +Also, it is not required to lift every `Monad*` typeclass (like `MonadError`) +though all transformers. + +## Quickstart + +To experiment with this library, it is suggested to write some lines within +`ghci`. + +Recommended Procedure: + +1. get `extensible-effects` by doing one of the following: + * add `extensible-effects` as a dependency to a existing cabal or stack project + * `git clone https://github.com/suhailshergill/extensible-effects.git` +2. start `stack ghci` or `cabal repl` inside the project +3. import `Control.Eff` and `Control.Eff.QuickStart` +4. start with the examples provided in the documentation of the `Control.Eff.QuickStart` module + +## Tour through Extensible Effects + +This section explains the basic concepts of this library. + +### The Effect List + +```haskell +import Control.Eff +``` + +The effect list `r` in the type `Eff r a` is a central concept in this library. +It is a type-level list containing effect types. + +If `r` is the empty list, then the computation `Eff r` (or `Eff '[]`) does not +contain any effects to be handled and therefore is a pure computation. +In this case, the result value can be retrieved by `run :: Eff '[] a -> a` + +For programming within the `Eff r` monad, it is almost never necessary to list +all effects that can appear. +It suffices to state what types of effects are at least required. +This is done via the `Member t r` typeclass. It describes that the type `t` +occurs inside the list `r`. +If you really want, you can still list all Effects and their order in which +they are used (e.g. `Eff '[Reader r, State s] a`). + +### Handling Effects + +Functions containing something like `Eff (x ': r) a -> Eff r a` handle effects. + +The transition from the longer list of effects `(x ': r)` to just `r` +is a type-level indicator that the effect `x` has been handled. +Depending on the effect, some additional input might be required or some +different output than just `a` is produced. + +The handler functions typically are called `run*`, `eval*` or `exec*`. + +### Most common Effects + +The most common effects used are `Writer`, `Reader`, `Exception` and `State`. + +`Writer`, `Reader` and `State` all provide lazy and strict variants. Each has +its own module that exposes a common interface. Importing one or the other +controls whether the effect is strict or lazy in its inputs and outputs. It's +recommended that you use the lazy variants by default unless you know you need +strictness. + +In this section, only the core functions associated with an effect are +presented. +Have a look at the modules for additional details. + +#### The Exception Effect + +```haskell +import Control.Eff.Exception +``` + +The exception effect adds the possibility to exit a computation preemptively +with an exception. +Note that the exceptions from this library are handled by the programmer and +have nothing to do with exceptions thrown inside the Haskell run-time. + +```haskell +throwError :: Member (Exc e) r => e -> Eff r a +runError :: Eff (Exc e ': r) a -> Eff r (Either e a) +``` + +An exception can be thrown using the `throwError` function. +Its return type is `Eff r a` with an arbitrary type `a`. +When handling the effect, the result-type changes to `Either e a` instead of +just `a`. +This indicates how the effect is handled: The returned value is either the +thrown exception or the value returned from a successful computation. + +#### The State Effect + +```haskell +import Control.Eff.State.{Lazy | Strict} +``` + +The state effect provides readable and writable state during a computation. + +```haskell +get :: Member (State s) r => Eff r s +put :: Member (State s) r => s -> Eff r () +modify :: Member (State s) r => (s -> s) -> Eff r () +runState :: s -> Eff (State s ': r) a -> Eff r (a, s) +``` + +The `get` function fetches the current state and makes it available within +subsequent computation. The `put` function sets the state to a given value. +`modify` updates the state using a mapping function by combining `get` and +`put`. + +The state-effect is handled using the `runState` function. +It takes the initial state as an argument and returns the final state and +effect-result. + +#### The Reader Effect + +```haskell +import Control.Eff.Reader.{Strict | Lazy} +``` + +The reader effect provides an environment that can be read. +Sometimes it is considered as read-only state. + +```haskell +ask :: Member (Reader e) r => e -> Eff r e +runReader :: e -> Eff (Reader e ': r) a -> Eff r a +``` + +`ask` can be used to retrieve the environment provided to `runReader` from +within a computation which has the `Reader` effect. + +#### The Writer Effect + +```haskell +import Control.Eff.Writer.{Strict | Lazy} +``` + +The writer effect allows one to collect messages during a computation. +It is sometimes referred to as write-only state, which gets retrieved at the +end of the computation. + +```haskell +tell :: Member (Writer w) r => w -> Eff r () +runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) +runListWriter :: Eff (Writer w ': r) a -> Eff r (a, [w]) +``` + +Running a writer can be done in several ways. +The most general function is `runWriter` which folds over all written values. +However, if you only want to collect the values written, the `runListWriter` +function does that. + +Note that compared to mtl, the value written has no Monoid constraint on it and +can be collected in any way. + +### Using multiple Effects + +The main benefit of this library is that multiple effects can be included +with ease. + +If you need state and want to be able exit the computation with an exception, +the type of your effectful computation would be the one of `myComp` below. +Then, both the state and exception effect-functions can be used. +To handle the effects, both the `runState` and `runError` functions have to be +provided. + +```haskell +myComp :: (Member (Exc e) r, Member (State s) r) => Eff r a + +run1 :: (Either e a, s) +run1 = run . runState initalState . runError $ myComp + +run2 :: Either e (a, s) +run2 = run . runError . runState initalState $ myComp +``` + +However, the order of the handlers does matter for the final result. +`run1` and `run2` show different executions of the same effectful computation. +In `run1`, the returned state `s` is the last state seen before an eventual +exception gets thrown (similar to the semantics in typical imperative +languages), while in `run2` the final state is returned only if the whole +computation succeeded - transaction style. + +### Tips and tricks + +There are several constructs that make it easier to work with the effects. + +If only a part of the result is necessary for further computation, have a +look at the `eval*` and `exec*` functions which exist for some effects. +The `exec*` functions discard the result of the computation (the `a` type). +The `eval*` functions discard the final result of the effect. + +Instead of writing +`(Member (Exc e) r, Member (State s) r) => ...` it is +possible to use the type operator `<::` and write +`[ Exc e, State s ] <:: r => ...`, which has the same meaning. + +It might be convenient to include the necessary language extensions and disable +class-constraint warnings in your project's `.cabal` file (or `package.yaml` if +you're using `stack`). + +*Explanation is a work in progress.* + +## Other Effects + +*Work in progress.* + +## Integration with IO + +`IO` or any other monad can be used as a base type for the `Lift` effect. +There may be at most one instance of the `Lift` effect in the effects list, and it +must be handled last. `Control.Eff.Lift` exports the `runLift` handler and +`lift` function which provide the ability to run arbitrary monadic actions. +Also, there are convenient type aliases that allow for shorter type constraints. + +```haskell +f :: IO () +f = runLift $ do printHello + printWorld + +-- These two functions' types are equivalent. + +printHello :: SetMember Lift (Lift IO) r => Eff r () +printHello = lift (putStr "Hello") + +printWorld :: Lifted IO r => Eff r () +printWorld = lift (putStrLn " world!") +``` + +Note that, since `Lift` is a terminal effect, you do not need to use `run` to +extract pure values. Instead, `runLift` returns a value wrapped in whatever +monad you chose to use. + +Additionally, the `Lift` effect provides `MonadBase`, `MonadBaseControl`, and +`MonadIO` instances that may be useful, especially with packages like +[lifted-base](http://hackage.haskell.org/package/lifted-base), +[lifted-async](http://hackage.haskell.org/package/lifted-async), and other +code that uses those typeclasses. + +## Integration with Monad Transformers + +*Work in progress.* + +## Writing your own Effects and Handlers + +*Work in progress.* + +## Other packages + +Some other packages may implement various effects. Here is a rather incomplete +list: + +* [log-effect](http://hackage.haskell.org/package/log-effect) + +## Background + +`extensible-effects` is based on the work of +[Extensible Effects: An Alternative to Monad Transformers](http://okmij.org/ftp/Haskell/extensible/). +The [paper](http://okmij.org/ftp/Haskell/extensible/exteff.pdf) and +the followup [freer paper](http://okmij.org/ftp/Haskell/extensible/more.pdf) +contain details. Additional explanation behind the approach can be found on [Oleg's website](http://okmij.org/ftp/Haskell/extensible/). + +## Limitations + +### Ambiguity-Flexibility tradeoff +The extensibility of `Eff` comes at the cost of some ambiguity. A useful +pattern to mitigate this ambiguity is to specialize calls to effect handlers +using +[type application](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication) +or type annotation. Examples of this pattern can be seen in +[Example/Test.hs](./test/Control/Eff/Example/Test.hs). + +Note, however, that the extensibility can also be traded back, but that detracts +from some of the advantages. For details see section 4.1 in the +[paper](http://okmij.org/ftp/Haskell/extensible/exteff.pdf). + +Some examples where the cost of extensibility is apparent: + + * Common functions can't be grouped using typeclasses, e.g. the `ask` and + `getState` functions can't be grouped in the case of: + + ```haskell + class Get t a where + ask :: Member (t a) r => Eff r a + ``` + + `ask` is inherently ambiguous, since the type signature only provides + a constraint on `t`, and nothing more. To specify fully, a parameter + involving the type `t` would need to be added, which would defeat the + point of having the grouping in the first place. + * Code requires a greater number of type annotations. For details see + [#31](https://github.com/suhailshergill/extensible-effects/issues/31). diff --git a/benchmark/Benchmarks.hs b/benchmark/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmarks.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- The simplest/silliest of all benchmarks! + +import Criterion.Main +import Control.Eff as E +import Control.Eff.Exception as E.Er +import Control.Eff.Logic.NDet as E.ND +import Control.Eff.State.Strict as E.S +import Control.Monad + +-- For comparison +-- We use a strict State monad, because of large space leaks with the +-- lazy monad (one test even overflows the stack) +import Control.Monad.State.Strict as S +import Control.Monad.Except as Er +-- import Control.Monad.Reader as Rd +import Control.Monad.Cont as Ct +import Control.Applicative + +-- For sanity-checking +import qualified Test.Framework as TF +import qualified Test.Framework.TH as TF.TH +import Test.Framework.Providers.HUnit (testCase) +import qualified Test.HUnit as HU + +main :: IO () +main = defaultMain [ + bgroup "state" [ bgroup "10k" [ bench "mtl" $ whnf benchCnt_State 10000 + , bench "eff" $ whnf benchCnt_Eff 10000 + ] + ] + , bgroup "error" [ bgroup "50k" [ bench "mtl" $ whnf benchMul_Error 50000 + , bench "eff" $ whnf benchMul_Eff 50000 + ] + ] + , bgroup "st-error" [ bgroup "err : st" [ bench "mtl" $ whnf mainMax_MTL 10000 + , bench "eff" $ whnf mainMax_Eff 10000 + ] + , bgroup "st : err" [ bench "mtl" $ whnf mainMax1_MTL 10000 + , bench "eff" $ whnf mainMax1_Eff 10000 + ] + ] + , bgroup "pyth" [ bgroup "ndet" [ bench "mtl" $ whnf mainN_MTL 100 + , bench "eff" $ whnf mainN_Eff 100 + ] + , bgroup "ndet : st" [ bench "mtl" $ nf mainNS_MTL 100 + , bench "eff" $ nf mainNS_Eff 100 + ] + ] + ] + >> TF.defaultMainWithArgs [ $(TF.TH.testGroupGenerator) ] testOpts + where + testOpts = [ "--color" ] + +-- ------------------------------------------------------------------------ +-- Single State, with very little non-effectful computation +-- This is a micro-benchmark, and hence not particularly realistic. +-- Because of its simplicity, GHC may do a lot of inlining. +-- See a more realistic max benchmark below, which does a fair amount +-- of computation other than accessing the state. + +-- Count-down +benchCnt_State :: Int -> ((),Int) +benchCnt_State n = S.runState m n + where + m = do + x <- S.get + if x > 0 then S.put (x-1) >> m else return () + +benchCnt_Eff :: Int -> ((),Int) +benchCnt_Eff n = run $ E.S.runState n m + where + m = do + x <- E.S.get + if x > 0 then E.S.put (x-1::Int) >> m else return () + +-- ------------------------------------------------------------------------ +-- Single Error + +-- Multiply a list of numbers, throwing an exception when encountering 0 +-- This is again a mcro-benchmark + +-- make a list of n ones followed by 0 +be_make_list :: Int -> [Int] +be_make_list n = replicate n 1 ++ [0] + +benchMul_Error :: Int -> Int +benchMul_Error n = either id id m + where + m = foldM f 1 (be_make_list n) + f acc 0 = Er.throwError 0 + f acc x = return $! acc * x + +benchMul_Eff :: Int -> Int +benchMul_Eff n = either id id . run . runError $ m + where + m = foldM f 1 (be_make_list n) + f acc 0 = E.Er.throwError (0::Int) + f acc x = return $! acc * x + +-- ------------------------------------------------------------------------ +-- State and Error and non-effectful computation + +benchMax_MTL :: (MonadState Int m, MonadError Int m) => Int -> m Int +benchMax_MTL n = foldM f 1 [n, n-1 .. 0] + where + f acc 0 = Er.throwError 0 + f acc x | x `mod` 5 == 0 = do + s <- S.get + S.put $! (s+1) + return $! max acc x + f acc x = return $! max acc x + +mainMax_MTL n = S.runState (Er.runExceptT (benchMax_MTL n)) 0 + +-- Different order of layers +mainMax1_MTL n = (S.runStateT (benchMax_MTL n) 0 :: Either Int (Int,Int)) + +benchMax_Eff :: (Member (Exc Int) r, Member (E.S.State Int) r) => + Int -> Eff r Int +benchMax_Eff n = foldM f 1 [n, n-1 .. 0] + where + f acc 0 = E.Er.throwError (0::Int) + f acc x | x `mod` 5 == 0 = do + s <- E.S.get + E.S.put $! (s+1::Int) + return $! max acc x + f acc x = return $! max acc x + + +mainMax_Eff n = ((run $ E.S.runState 0 (E.Er.runError (benchMax_Eff n))) :: + (Either Int Int,Int)) + +mainMax1_Eff n = ((run $ E.Er.runError (E.S.runState 0 (benchMax_Eff n))) :: + Either Int (Int,Int)) + +-- ------------------------------------------------------------------------ +-- Non-determinism benchmark: Pythagorian triples + +-- First benchmark, with non-determinism only + +-- Stream from k to n +iota k n = if k > n then mzero else return k `mplus` iota (k+1) n + +pyth1 :: MonadPlus m => Int -> m (Int, Int, Int) +pyth1 upbound = do + x <- iota 1 upbound + y <- iota 1 upbound + z <- iota 1 upbound + if x*x + y*y == z*z then return (x,y,z) else mzero + +pyth20 = + [(3,4,5),(4,3,5),(5,12,13),(6,8,10),(8,6,10),(8,15,17),(9,12,15),(12,5,13), + (12,9,15),(12,16,20),(15,8,17),(16,12,20)] + + +case_pythr_ndet :: HU.Assertion +case_pythr_ndet = + HU.assertEqual "pythr_MTL" pyth20 ((runCont (pyth1 20) (\x -> [x])) :: [(Int,Int,Int)]) + >> HU.assertEqual "pythr_EFF" pyth20 ((run . E.ND.makeChoice $ pyth1 20) :: [(Int,Int,Int)]) + + +-- There is no instance of MonadPlus for ContT +-- we have to make our own + +instance Monad m => MonadPlus (ContT [r] m) where + mzero = ContT $ \k -> return [] + mplus (ContT m1) (ContT m2) = ContT $ \k -> + liftM2 (++) (m1 k) (m2 k) + +instance Monad m => Alternative (ContT [r] m) where + empty = mzero + (<|>) = mplus + +mainN_MTL n = ((runCont (pyth1 n) (\x -> [x])) :: [(Int,Int,Int)]) + +mainN_Eff n = ((run . E.ND.makeChoice $ pyth1 n) :: [(Int,Int,Int)]) + +-- Adding state: counting the number of choices + +pyth2 :: Int -> ContT [r] (S.State Int) (Int, Int, Int) +pyth2 upbound = do + x <- iota 1 upbound + y <- iota 1 upbound + z <- iota 1 upbound + cnt <- S.get + S.put $! (cnt + 1) + if x*x + y*y == z*z then return (x,y,z) else mzero + +pyth2E :: (Member (E.S.State Int) r, Member NDet r) => + Int -> Eff r (Int, Int, Int) +pyth2E upbound = do + x <- iota 1 upbound + y <- iota 1 upbound + z <- iota 1 upbound + cnt <- E.S.get + E.S.put $! (cnt + 1::Int) + if x*x + y*y == z*z then return (x,y,z) else mzero + + +mainNS_MTL n = + let (l,cnt) = pythrNS_MTL n + in ((l::[(Int,Int,Int)]), (cnt::Int)) + where + pythrNS_MTL :: Int -> ([(Int,Int,Int)],Int) + pythrNS_MTL n = S.runState (runContT (pyth2 n) (\x -> return [x])) 0 + +mainNS_Eff n = + let (l,cnt) = pyth2Er n + in ((l::[(Int,Int,Int)]), (cnt::Int)) + where + pyth2Er :: Int -> ([(Int,Int,Int)],Int) + pyth2Er n = run . E.S.runState 0 . E.ND.makeChoice $ pyth2E n diff --git a/extensible-effects.cabal b/extensible-effects.cabal --- a/extensible-effects.cabal +++ b/extensible-effects.cabal @@ -1,63 +1,245 @@ -Name: extensible-effects -Version: 1.2.1 -Synopsis: An Alternative to Monad Transformers -Description: This package introduces datatypes for typeclass-constrained effects, +name: extensible-effects + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 5.0.0.1 + +-- A short (one-line) description of the package. +synopsis: An Alternative to Monad Transformers + +-- A longer description of the package. +description: This package introduces datatypes for typeclass-constrained effects, as an alternative to monad-transformer based (datatype-constrained) approach of multi-layered effects. - For more information, see the original paper at - . Any help is appreciated! -Category: Control, Effect -Author: Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa -Stability: Experimental -Homepage: https://github.com/RobotGymnast/extensible-effects -Maintainer: benjamin.foppa@gmail.com -License: MIT -Tested-With: GHC==7.6.3 -Build-Type: Simple -Cabal-Version: >= 1.9.2 +stability: Experimental + +-- URL for the project homepage or repository. +homepage: https://github.com/suhailshergill/extensible-effects + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: suhailshergill@gmail.com + +-- A copyright notice. +-- copyright: + +category: Control, Effect + +tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2 + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: README.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +flag lib-Werror + default: False + manual: True + +flag dump-core + description: Dump HTML for the core generated by GHC during compilation + default: False + library - hs-source-dirs: src/ - ghc-options: -Wall - extensions: Trustworthy - exposed-modules: Control.Eff - Control.Eff.Choose + ghc-options: -Wall -O2 + -- Modules exported by the library. + exposed-modules: Control.Eff Control.Eff.Coroutine - Control.Eff.Cut + Control.Eff.Example Control.Eff.Exception - Control.Eff.Fail Control.Eff.Fresh - Control.Eff.Lift + Control.Eff.Logic.Core + Control.Eff.Logic.NDet + Control.Eff.Operational + Control.Eff.Operational.Example Control.Eff.Reader.Lazy + Control.Eff.State.OnDemand Control.Eff.Reader.Strict Control.Eff.State.Lazy Control.Eff.State.Strict + Control.Eff.Trace Control.Eff.Writer.Lazy Control.Eff.Writer.Strict - Control.Eff.Trace - other-modules: Data.OpenUnion1 + Data.OpenUnion + Control.Eff.QuickStart + Control.Eff.Extend - build-depends: - base == 4.* + -- Modules included in this library but not exported. + other-modules: Control.Eff.Internal + Data.FTCQueue + Control.Eff.Logic.Experimental + default-extensions: NoMonomorphismRestriction + , MonoLocalBinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , MultiParamTypeClasses + , RankNTypes + , ScopedTypeVariables + , DataKinds + , TypeOperators + , PolyKinds + , KindSignatures + -- LANGUAGE extensions used by modules in this package. + other-extensions: BangPatterns + , CPP + , DeriveDataTypeable + , DeriveFunctor + , EmptyDataDecls + , ExistentialQuantification + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GeneralizedNewtypeDeriving + , KindSignatures + , MultiParamTypeClasses + , NoMonomorphismRestriction + , PatternGuards + , PolyKinds + , RankNTypes + , Safe + , ScopedTypeVariables + , TupleSections + , Trustworthy + , TypeOperators + , UndecidableInstances + + -- Other library packages from which modules are imported. + build-depends: base >= 4.7 && < 5 + -- For MonadBase + , transformers-base == 0.4.* + -- For MonadBaseControl + , monad-control >= 1.0 && < 1.1 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + + if flag(lib-Werror) + ghc-options: -Werror + + if flag(dump-core) + build-depends: dump-core + ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html + test-suite extensible-effects-tests type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test/ + other-modules: Utils + , Control.Eff.Test + , Control.Eff.Coroutine.Test + , Control.Eff.Example.Test + , Control.Eff.Exception.Test + , Control.Eff.Fresh.Test + , Control.Eff.Logic.NDet.Bench + , Control.Eff.Logic.NDet.Test + , Control.Eff.Logic.Test + , Control.Eff.Operational.Test + , Control.Eff.Reader.Lazy.Test + , Control.Eff.Reader.Strict.Test + , Control.Eff.State.Lazy.Test + , Control.Eff.State.OnDemand.Test + , Control.Eff.State.Strict.Test + , Control.Eff.Trace.Test + , Control.Eff.Writer.Lazy.Test + , Control.Eff.Writer.Strict.Test + , DoctestRun - ghc-options: -rtsopts=all -threaded + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-type-defaults -Wno-missing-signatures -Wno-name-shadowing + if impl(ghc < 8.0) + ghc-options: -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-name-shadowing build-depends: - base == 4.*, - QuickCheck == 2.*, - HUnit == 1.2.*, - test-framework == 0.8.*, - test-framework-hunit == 0.3.*, - test-framework-quickcheck2 == 0.3.*, - extensible-effects + base >= 4.7 && < 5 + , QuickCheck + , HUnit + , monad-control >= 1.0 + , mtl + , silently >= 1.2 + , test-framework == 0.8.* + , test-framework-hunit == 0.3.* + , test-framework-quickcheck2 == 0.3.* + , test-framework-th >= 0.2 + , doctest + , extensible-effects + default-language: Haskell2010 + default-extensions: NoMonomorphismRestriction + , MonoLocalBinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , MultiParamTypeClasses + , RankNTypes + , ScopedTypeVariables + , DataKinds + , TypeOperators + , PolyKinds + , KindSignatures + +benchmark extensible-effects-benchmarks + type: exitcode-stdio-1.0 + main-is: Benchmarks.hs + hs-source-dirs: benchmark/ + ghc-options: -Wall -O2 -threaded -rtsopts + if impl(ghc >= 8.0) + ghc-options: -Wno-type-defaults -Wno-missing-signatures + -Wno-name-shadowing -Wno-unused-matches + if impl(ghc < 8.0) + ghc-options: -fno-warn-type-defaults -fno-warn-missing-signatures + -fno-warn-name-shadowing -fno-warn-unused-matches + + build-depends: + base >= 4.7 && < 5 + , criterion + , extensible-effects + , mtl + , HUnit + , test-framework == 0.8.* + , test-framework-hunit == 0.3.* + , test-framework-quickcheck2 == 0.3.* + , test-framework-th >= 0.2 + + default-language: Haskell2010 + default-extensions: NoMonomorphismRestriction + , MonoLocalBinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , MultiParamTypeClasses + , RankNTypes + , ScopedTypeVariables + , DataKinds + , TypeOperators + , PolyKinds + , KindSignatures + source-repository head type: git - location: https://github.com/RobotGymnast/extensible-effects + location: https://github.com/suhailshergill/extensible-effects.git diff --git a/src/Control/Eff.hs b/src/Control/Eff.hs --- a/src/Control/Eff.hs +++ b/src/Control/Eff.hs @@ -1,159 +1,40 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, DeriveFunctor #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ExplicitNamespaces #-} --- | Original work available at . --- This module implements extensible effects as an alternative to monad transformers, --- as described in . +-- | A monadic library for implementing effectful computation in a modular way. -- --- Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype. --- A contrived example is: +-- This module provides the @Eff@ monad - the base type for all effectful +-- computation. +-- The @Member@ typeclass is the main interface for describing which effects +-- are necessary for a given function. -- --- > {-# LANGUAGE FlexibleContexts #-} --- > import Control.Eff --- > import Control.Eff.Lift --- > import Control.Eff.State --- > import Control.Monad (void) --- > import Data.Typeable --- > --- > -- Write the elements of a list of numbers, in order. --- > writeAll :: (Typeable a, Member (Writer a) e) --- > => [a] --- > -> Eff e () --- > writeAll = mapM_ putWriter --- > --- > -- Add a list of numbers to the current state. --- > sumAll :: (Typeable a, Num a, Member (State a) e) --- > => [a] --- > -> Eff e () --- > sumAll = mapM_ (onState . (+)) --- > --- > -- Write a list of numbers and add them to the current state. --- > writeAndAdd :: (Member (Writer Integer) e, Member (State Integer) e) --- > => [Integer] --- > -> Eff e () --- > writeAndAdd l = do --- > writeAll l --- > sumAll l --- > --- > -- Sum a list of numbers. --- > sumEff :: (Num a, Typeable a) => [a] -> a --- > sumEff l = let (s, ()) = run $ runState 0 $ sumAll l --- > in s --- > --- > -- Safely get the last element of a list. --- > -- Nothing for empty lists; Just the last element otherwise. --- > lastEff :: Typeable a => [a] -> Maybe a --- > lastEff l = let (a, ()) = run $ runWriter $ writeAll l --- > in a --- > --- > -- Get the last element and sum of a list --- > lastAndSum :: (Typeable a, Num a) => [a] -> (Maybe a, a) --- > lastAndSum l = let (lst, (total, ())) = run $ runWriter $ runState 0 $ writeAndAdd l --- > in (lst, total) -module Control.Eff( - Eff - , VE (..) - , Member - , SetMember - , Union - , (:>) - , inj - , prj - , prjForce - , decomp - , send - , admin - , run - , interpose - , handleRelay - , unsafeReUnion - ) where - -import Control.Applicative (Applicative (..), (<$>)) -import Control.Monad (ap) -import Data.OpenUnion1 -import Data.Typeable - --- | A `VE` is either a value, or an effect of type @`Union` r@ producing another `VE`. --- The result is that a `VE` can produce an arbitrarily long chain of @`Union` r@ --- effects, terminated with a pure value. -data VE w r = Val w | E !(Union r (VE w r)) - deriving Typeable - -fromVal :: VE w r -> w -fromVal (Val 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 w r) -> VE w r } - 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 - {-# INLINE return #-} - {-# INLINE (>>=) #-} - return x = Eff $ \k -> k x - m >>= f = Eff $ \k -> runEff m (\v -> runEff (f v) k) - --- | Given a method of turning requests into results, --- we produce an effectful computation. -send :: (forall w. (a -> VE w r) -> Union r (VE w r)) -> Eff r a -send f = Eff (E . f) -{-# INLINE send #-} - --- | Tell an effectful computation that you're ready to start running effects --- and return a value. -admin :: Eff r w -> VE w r -admin (Eff m) = m Val -{-# INLINE admin #-} - --- | Get the result from a pure computation. -run :: Eff () w -> w -run = fromVal . admin -{-# INLINE run #-} - --- the other case is unreachable since () has no constructors --- Therefore, run is a total function if m Val terminates. +-- Consult the @Control.Eff.QuickStart@ module and the readme for gentle +-- introductions. +-- +-- To use extensible effects effectively some language extensions are +-- necessary/recommended. +-- +-- @ +-- {-\# LANGUAGE ScopedTypeVariables \#-} +-- {-\# LANGUAGE FlexibleContexts \#-} +-- {-\# LANGUAGE MonoLocalBinds \#-} +-- @ +-- --- | Given a request, either handle it or relay it. -handleRelay :: Typeable1 t - => Union (t :> r) v -- ^ Request - -> (v -> Eff r a) -- ^ Relay the request - -> (t v -> Eff r a) -- ^ Handle the request of type t - -> Eff r a -handleRelay u loop h = either passOn h $ decomp u - where passOn u' = send (<$> u') >>= loop - -- perhaps more efficient: - -- passOn u' = send (\k -> fmap (\w -> runEff (loop w) k) u') -{-# INLINE handleRelay #-} +module Control.Eff + ( -- * Effect type + Internal.run + , Internal.Eff + -- * Lift IO computations + , Internal.lift, Internal.runLift + , Internal.catchDynE + , Internal.HandlerDynE(..), Internal.catchesDynE + , Internal.Lift(..), Internal.Lifted, Internal.LiftedBase + -- * Effect list + , OpenUnion.Member + , OpenUnion.SetMember + , type(<::) + ) where --- | Given a request, either handle it or relay it. Both the handler --- and the relay can produce the same type of request that was handled. -interpose :: (Typeable1 t, Functor t, Member t r) - => Union r v - -> (v -> Eff r a) - -> (t v -> Eff r a) - -> Eff r a -interpose u loop h = maybe (send (<$> u) >>= loop) h $ prj u -{-# INLINE interpose #-} +import Control.Eff.Internal as Internal +import Data.OpenUnion as OpenUnion diff --git a/src/Control/Eff/Choose.hs b/src/Control/Eff/Choose.hs deleted file mode 100644 --- a/src/Control/Eff/Choose.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} --- | Nondeterministic choice effect -module Control.Eff.Choose( Choose (..) - , choose - , runChoice - , mzero' - , mplus' - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (join) -import Data.Typeable - -import Control.Eff - --- | Nondeterministic choice -data Choose v = forall a. Choose [a] (a -> v) - deriving (Typeable) - -instance Functor Choose where - fmap f (Choose lst k) = Choose lst (f . k) - --- | choose lst non-deterministically chooses one value from the lst --- choose [] thus corresponds to failure -choose :: Member Choose r => [a] -> Eff r a -choose lst = send (inj . Choose lst) - --- | MonadPlus-like operators are expressible via choose -mzero' :: Member Choose r => Eff r a -mzero' = choose [] - --- | MonadPlus-like operators are expressible via choose -mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a -mplus' m1 m2 = join $ choose [m1,m2] - --- | Run a nondeterministic effect, returning all values. -runChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a] -runChoice m = loop (admin m) - where - loop (Val x) = return [x] - loop (E u) = handleRelay u loop (\(Choose lst k) -> handle lst k) - - handle :: [t] -> (t -> VE a (Choose :> r)) -> Eff r [a] - handle [] _ = return [] - handle [x] k = loop (k x) - handle lst k = concat <$> mapM (loop . k) lst diff --git a/src/Control/Eff/Coroutine.hs b/src/Control/Eff/Coroutine.hs --- a/src/Control/Eff/Coroutine.hs +++ b/src/Control/Eff/Coroutine.hs @@ -1,27 +1,33 @@ {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Safe #-} -- | Coroutines implemented with extensible effects -module Control.Eff.Coroutine( Yield +module Control.Eff.Coroutine( Yield (..) + , withCoroutine , yield , runC , Y (..) ) where -import Data.Typeable - import Control.Eff +import Control.Eff.Extend +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | Co-routines +-- The interface is intentionally chosen to be the same as in transf.hs +-- -- | The yield request: reporting a value of type e and suspending --- the coroutine. For readability, a coroutine accepts a unit to produce --- its value. -data Yield a v = Yield a (() -> v) - deriving (Typeable, Functor) +-- the coroutine. Resuming with the value of type b +data Yield a b v where + Yield :: a -> Yield a b b -- | Yield a value of type a and suspend the coroutine. -yield :: (Typeable a, Member (Yield a) r) => a -> Eff r () -yield x = send (inj . Yield x) +yield :: (Member (Yield a b) r) => a -> Eff r b +yield x = send (Yield x) -- | Status of a thread: done or reporting the value of the type a -- (For simplicity, a co-routine reports a value but accepts unit) @@ -32,13 +38,16 @@ -- -- Type parameter @w@ is the type of the value returned from the -- coroutine when it has completed. -data Y r a w = Y a (() -> Eff r (Y r a w)) - | Done w +data Y r w a = Y (w -> Eff r (Y r w a)) a + | Done --- | Launch a thread and report its status. -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 $ - \(Yield x k) -> return (Y x (loop . k)) +-- | Return a pure value +withCoroutine :: Monad m => b -> m (Y r w a) +withCoroutine = const $ return Done +-- | Given a continuation and a request, respond to it +instance Handle (Yield a b) (Yield a b : r) w (Eff r (Y r b a)) where + handle step q (Yield a) = return $ Y (step . (q ^$)) a + +-- | Launch a thread and report its status +runC :: Eff (Yield a b ': r) w -> Eff r (Y r b a) +runC = fix (handle_relay withCoroutine) diff --git a/src/Control/Eff/Cut.hs b/src/Control/Eff/Cut.hs deleted file mode 100644 --- a/src/Control/Eff/Cut.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} --- | An example of non-trivial interaction of effects, handling of two --- effects together --- Non-determinism with control (cut) --- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper. --- Hinze suggests expressing cut in terms of cutfalse: --- --- > = return () `mplus` cutfalse --- > where --- > cutfalse :: m a --- --- satisfies the following laws: --- --- > cutfalse >>= k = cutfalse (F1) --- > cutfalse | m = cutfalse (F2) --- --- (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@) --- In other words, cutfalse is the left zero of both bind and mplus. --- --- Hinze also introduces the operation @`call` :: m a -> m a@ that --- delimits the effect of cut: @`call` m@ executes m. If the cut is --- invoked in m, it discards only the choices made since m was called. --- Hinze postulates the axioms of `call`: --- --- > call false = false (C1) --- > call (return a | m) = return a | call m (C2) --- > call (m | cutfalse) = call m (C3) --- > call (lift m >>= k) = lift m >>= (call . k) (C4) --- --- @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect, --- he says. --- --- Hinze noted a problem with the \"mechanical\" derivation of backtracing --- monad transformer with cut: no axiom specifying the interaction of --- call with bind; no way to simplify nested invocations of call. --- --- We use exceptions for cutfalse --- Therefore, the law @cutfalse >>= k = cutfalse@ --- is satisfied automatically since all exceptions have the above property. -module Control.Eff.Cut( CutFalse - , call - , cutfalse - ) where - -import Control.Applicative ((<$>)) -import Data.Typeable - -import Control.Eff -import Control.Eff.Choose -import Control.Eff.Exception - -data CutFalse = CutFalse deriving Typeable - -cutfalse :: Member (Exc CutFalse) r => Eff r a -cutfalse = throwExc CutFalse - --- | The interpreter -- it is like reify . reflect with a twist --- Compare this implementation with the huge implementation of call --- in Hinze 2000 (Figure 9) --- Each clause corresponds to the axiom of call or cutfalse. --- All axioms are covered. --- The code clearly expresses the intuition that call watches the choice points --- of its argument computation. When it encounteres a cutfalse request, --- it discards the remaining choicepoints. --- It completely handles CutFalse effects but not non-determinism. -call :: Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a -call m = loop [] (admin m) where - loop jq (Val x) = return x `mplus'` next jq -- (C2) - loop jq (E u) = case decomp u of - Right (Exc CutFalse) -> mzero' -- drop jq (F2) - Left u' -> check jq u' - - check jq u | Just (Choose [] _) <- prj u = next jq -- (C1) - check jq u | Just (Choose [x] k) <- prj u = loop jq (k x) -- (C3), optim - check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3) - check jq u = send (<$> u) >>= loop jq -- (C4) - - next [] = mzero' - next (h:t) = loop t h diff --git a/src/Control/Eff/Example.hs b/src/Control/Eff/Example.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Example.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators, GADTs, DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} + +-- | Example usage of "Control.Eff" +module Control.Eff.Example where + +import Control.Eff +import Control.Eff.Extend +import Control.Eff.Exception + +import Control.Eff.Reader.Lazy +import Control.Eff.State.Lazy +import Control.Eff.Writer.Lazy + +-- {{{ TooBig + +-- | The datatype for the example from the paper. See the tests for the example +newtype TooBig = TooBig Int deriving (Eq, Show) + +-- | specialization to tell the type of the exception +runErrBig :: Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a) +runErrBig = runError + +-- }}} + +-- | Multiple Reader effects +sum2 :: ([ Reader Int + , Reader Float + ] <:: r) => Eff r Float +sum2 = do + v1 <- ask + v2 <- ask + return $ fromIntegral (v1 + (1 :: Int)) + (v2 + (2 :: Float)) + +-- | Write the elements of a list of numbers, in order. +writeAll :: (Member (Writer a) e) + => [a] + -> Eff e () +writeAll = mapM_ tell + +-- | Add a list of numbers to the current state. +sumAll :: (Num a, Member (State a) e) + => [a] + -> Eff e () +sumAll = mapM_ (modify . (+)) + +-- | Write a list of numbers and add them to the current state. +writeAndAdd :: ( [ Writer a + , State a + ] <:: e + , Num a) + => [a] + -> Eff e () +writeAndAdd l = do + writeAll l + sumAll l + +-- | Sum a list of numbers. +sumEff :: (Num a) => [a] -> a +sumEff l = let ((), s) = run $ runState 0 (sumAll l) + in s + +-- | Safely get the last element of a list. +-- Nothing for empty lists; Just the last element otherwise. +lastEff :: [a] -> Maybe a +lastEff l = let ((), a) = run $ runLastWriter $ writeAll l + in a + + +-- | Get the last element and sum of a list +lastAndSum :: (Num a) => [a] -> (Maybe a, a) +lastAndSum l = let (((), total), lst) = + run $ runLastWriter $ runState 0 (writeAndAdd l) + in (lst, total) + + +-- Example by Oscar Key +data Move x where + Move :: Move () + +handUp :: Eff (Move ': r) a -> Eff r a +handUp (Val x) = return x +handUp (E q u) = case decomp u of + Right Move -> handDown $ qApp q () + -- Relay other requests + Left u0 -> E ident u0 >>= handUp . qApp q + +handDown :: Eff (Move ': r) a -> Eff r a +handDown (Val x) = return x +handDown (E q u) = case decomp u of + Right Move -> handUp $ qApp q () + -- Relay other requests + Left u0 -> E ident u0 >>= handDown . qApp q diff --git a/src/Control/Eff/Exception.hs b/src/Control/Eff/Exception.hs --- a/src/Control/Eff/Exception.hs +++ b/src/Control/Eff/Exception.hs @@ -1,40 +1,144 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} -- | Exception-producing and exception-handling effects -module Control.Eff.Exception( Exc(..) - , throwExc - , runExc - , catchExc +module Control.Eff.Exception ( Exc (..) + , exc + , withException + , Fail + , throwError + , throwError_ + , die + , runError + , runFail + , catchError + , onFail + , rethrowError + , liftEither + , liftEitherM + , liftMaybe + , liftMaybeM + , ignoreFail ) where -import Data.Typeable - import Control.Eff +import Control.Eff.Extend --- | These are exceptions of the type e. This is akin to the error monad. +import Control.Monad (void) +import Control.Monad.Base +import Control.Monad.Trans.Control + +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | Exceptions +-- +-- exceptions of the type e; no resumption newtype Exc e v = Exc e - deriving (Functor, Typeable) --- | Throw an exception in an effectful computation. -throwExc :: (Typeable e, Member (Exc e) r) => e -> Eff r a -throwExc e = send (\_ -> inj $ Exc e) +-- | Embed a pure value +withException :: Monad m => a -> m (Either e a) +withException = return . Right +-- | Throw an error +exc :: Monad m => e -> m (Either e a) +exc = return . Left +-- | Given a callback, and an 'Exc' request, respond to it. +instance Monad m => Handle (Exc e) r a (m (Either e a)) where + handle _ _ (Exc e) = exc e +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (Exc e ': r)) where + type StM (Eff (Exc e ': r)) a = StM (Eff r) (Either e a) + liftBaseWith f = raise $ liftBaseWith $ \runInBase -> + f (runInBase . runError) + restoreM x = do r :: Either e a <- raise (restoreM x) + liftEither r + +type Fail = Exc () + +-- | Throw an exception in an effectful computation. The type is inferred. +throwError :: (Member (Exc e) r) => e -> Eff r a +throwError e = send (Exc e) +{-# INLINE throwError #-} + +-- | Throw an exception in an effectful computation. The type is unit, +-- which suppresses the ghc-mod warning "A do-notation statement +-- discarded a result of type" +throwError_ :: (Member (Exc e) r) => e -> Eff r () +throwError_ = throwError +{-# INLINE throwError_ #-} + +-- | Makes an effect fail, preventing future effects from happening. +die :: Member Fail r => Eff r a +die = throwError () +{-# INLINE die #-} + -- | Run a computation that might produce an exception. -runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a) -runExc m = loop (admin m) - where - loop (Val x) = return (Right x) - loop (E u) = handleRelay u loop (\(Exc e) -> return (Left e)) +runError :: Eff (Exc e ': r) a -> Eff r (Either e a) +runError = fix (handle_relay withException) --- | Run a computation that might produce exceptions, --- and give it a way to deal with the exceptions that come up. -catchExc :: (Typeable e, Member (Exc e) r) - => Eff r a - -> (e -> Eff r a) - -> Eff r a -catchExc m handle = loop (admin m) - where - loop (Val x) = return x - loop (E u) = interpose u loop (\(Exc e) -> handle e) +-- | Runs a failable effect, such that failed computation return 'Nothing', and +-- 'Just' the return value on success. +runFail :: Eff (Fail ': r) a -> Eff r (Maybe a) +runFail = fmap (either (const Nothing) Just) . runError +{-# INLINE runFail #-} + +-- | Run a computation that might produce exceptions, and give it a way to deal +-- with the exceptions that come up. The handler is allowed to rethrow the +-- exception +catchError :: Member (Exc e) r => + Eff r a -> (e -> Eff r a) -> Eff r a +catchError m h = fix (respond_relay' (\_ _ (Exc e) -> h e) return) m + +-- | Add a default value (i.e. failure handler) to a fallible computation. +-- This hides the fact that a failure happened. +onFail :: Eff (Fail ': r) a -- ^ The fallible computation. + -> Eff r a -- ^ The computation to run on failure. + -> Eff r a +onFail e handle_ = runFail e >>= maybe handle_ return +{-# INLINE onFail #-} + +-- | Run a computation until it produces an exception, +-- and convert and throw that exception in a new context. +rethrowError :: (Member (Exc e') r) + => (e -> e') + -> Eff (Exc e ': r) a + -> Eff r a +rethrowError t e = runError e >>= either (throwError . t) return + +-- | Treat Lefts as exceptions and Rights as return values. +liftEither :: (Member (Exc e) r) => Either e a -> Eff r a +liftEither = either throwError return +{-# INLINE liftEither #-} + +-- | `liftEither` in a lifted Monad +liftEitherM :: (Member (Exc e) r, Lifted m r) + => m (Either e a) + -> Eff r a +liftEitherM m = lift m >>= liftEither +{-# INLINE liftEitherM #-} + +-- | Lift a maybe into the 'Fail' effect, causing failure if it's 'Nothing'. +liftMaybe :: Member Fail r => Maybe a -> Eff r a +liftMaybe = maybe die return +{-# INLINE liftMaybe #-} + +-- | `liftMaybe` in a lifted Monad +liftMaybeM :: (Member Fail r, Lifted m r) + => m (Maybe a) + -> Eff r a +liftMaybeM m = lift m >>= liftMaybe +{-# INLINE liftMaybeM #-} + +-- | Ignores a failure event. Since the event can fail, you cannot inspect its +-- return type, because it has none on failure. To inspect it, use 'runFail'. +ignoreFail :: Eff (Fail ': r) a + -> Eff r () +ignoreFail e = void e `onFail` return () +{-# INLINE ignoreFail #-} diff --git a/src/Control/Eff/Extend.hs b/src/Control/Eff/Extend.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Extend.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | This module exports functions, types, and typeclasses necessary for +-- implementing a custom effect and/or effect handler. +-- + +module Control.Eff.Extend + ( -- * The effect monad + Eff(..) + , run + , eff + -- * Lifting operations + , Lift(..), Lifted, LiftedBase + , lift, runLift + , catchDynE + , HandlerDynE(..), catchesDynE + -- * Open Unions + , OpenUnion.Union + , OpenUnion.Member + , inj + , prj, pattern OpenUnion.U0' + , decomp, pattern OpenUnion.U0, pattern OpenUnion.U1 + , SetMember + , weaken + -- * Helper functions that are used for implementing effect-handlers + , Handle(..) + , Relay(..) + , handle_relay', respond_relay' + , raise + , send + -- * Arrow types and compositions + , Arr + , Arrs + , first + , singleK + , qApp + , (^$) + , arr + , ident + , comp + , (^|>) + , qComp + , qComps + ) +where + +import Data.OpenUnion as OpenUnion +import Control.Eff.Internal diff --git a/src/Control/Eff/Fail.hs b/src/Control/Eff/Fail.hs deleted file mode 100644 --- a/src/Control/Eff/Fail.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} --- | Effects which fail. -module Control.Eff.Fail( Fail - , die - , runFail - , ignoreFail - , onFail - ) where - -import Data.Typeable -import Control.Eff -import Control.Monad - --- | 'Fail' represents effects which can fail. This is akin to the Maybe monad. -data Fail v = Fail - deriving (Functor, Typeable) - --- | Makes an effect fail, preventing future effects from happening. -die :: Member Fail r - => Eff r () -die = send (const (inj Fail)) -{-# INLINE die #-} - --- | Runs a failable effect, such that failed computation return 'Nothing', and --- 'Just' the return value on success. -runFail :: Eff (Fail :> r) a - -> Eff r (Maybe a) -runFail m = loop (admin m) - where - loop (Val x) = return (Just x) - loop (E u) = handleRelay u loop (const (return Nothing)) -{-# INLINE runFail #-} - --- | Given a computation to run on failure, and a computation that can fail, --- this function runs the computation that can fail, and if it fails, gets --- the return value from the other computation. This hides the fact that a --- failure even happened, and returns a default value for when it does. -onFail :: Eff r a -- ^ The computation to run on failure. - -> Eff (Fail :> r) a -- ^ The computation which can fail. - -> Eff r a -onFail sideshow mainEvent = do - r <- runFail mainEvent - case r of - Nothing -> sideshow - Just y -> return y -{-# INLINE onFail #-} - --- | Ignores a failure event. Since the event can fail, you cannot inspect its --- return type, because it has none on failure. To inspect it, use 'runFail'. -ignoreFail :: Eff (Fail :> r) a - -> Eff r () -ignoreFail = onFail (return ()) . void -{-# INLINE ignoreFail #-} diff --git a/src/Control/Eff/Fresh.hs b/src/Control/Eff/Fresh.hs --- a/src/Control/Eff/Fresh.hs +++ b/src/Control/Eff/Fresh.hs @@ -1,30 +1,126 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Safe #-} -- | Create unique Enumerable values. -module Control.Eff.Fresh( Fresh +module Control.Eff.Fresh( Fresh (Fresh) + , withFresh , fresh - , runFresh + , runFresh' ) where -import Data.Typeable - import Control.Eff +import Control.Eff.Extend +import Control.Monad.Base +import Control.Monad.Trans.Control + +import Data.Function (fix) + +-- There are three possible implementations +-- The first one uses State Fresh where +-- newtype Fresh = Fresh Int +-- We get the `private' effect layer (State Fresh) that does not interfere +-- with with other layers. +-- This is the easiest implementation. + +-- The second implementation defines a new effect Fresh + -- | Create unique Enumerable values. -newtype Fresh i v = Fresh (i -> v) - deriving (Functor, Typeable) +data Fresh v where + Fresh :: Fresh Int + Replace :: !Int -> Fresh () +-- | Embed a pure value. Note that this is a specialized form of +-- State's and we could have reused it. +withFresh :: Monad m => a -> Int -> m (a, Int) +withFresh x s = return (x, s) + +-- | Given a continuation and requests, respond to them +instance Handle Fresh r a (Int -> k) where + handle step q req s = case req of + Fresh -> step (q ^$ s) (s+1) + Replace i -> step (q ^$ ()) i + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (Fresh ': r)) where + type StM (Eff (Fresh ': r)) a = StM (Eff r) (a, Int) + liftBaseWith f = do i <- fresh + raise $ liftBaseWith $ \runInBase -> + f (\k -> runInBase $ runFreshReturn i k) + restoreM x = do (r,i) <- raise (restoreM x) + replace i + return r + + -- | Produce a value that has not been previously produced. -fresh :: (Typeable i, Enum i, Member (Fresh i) r) => Eff r i -fresh = send (inj . Fresh) +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 :: (Typeable i, Enum i) => Eff (Fresh i :> r) w -> i -> Eff r w -runFresh m s0 = loop s0 (admin m) - where - loop _ (Val x) = return x - loop s (E u) = handleRelay u (loop s) $ - \(Fresh k) -> (loop $! succ s) (k s) +runFresh' :: Int -> Eff (Fresh ': r) w -> Eff r w +runFresh' s m = fst `fmap` runFreshReturn s m + +runFreshReturn :: Int -> Eff (Fresh ': r) w -> Eff r (w,Int) +runFreshReturn s m = fix (handle_relay withFresh) m s + +{- +-- Finally, the worst implementation but the one that answers +-- reviewer's question: implementing Fresh in terms of State +-- but not revealing that fact. + +runFresh :: Eff (Fresh :> r) w -> Int -> Eff r w +runFresh m s = runState m' s >>= return . fst + where + m' = loop m + loop (Val x) = return x + loop (E u q) = case decomp u of + Right Fresh -> do + n <- get + put (n+1::Int) + k n + Left u -> send (\k -> weaken $ fmap k u) >>= loop + +tfresh = runTrace $ flip runFresh 0 $ do + n <- fresh + -- (x::Int) <- get + trace $ "Fresh " ++ show n + n <- fresh + trace $ "Fresh " ++ show n + +{- +If we try to meddle with the encapsulated state, by uncommenting the +get statement above, we get: + No instance for (Member (State Int) Void) + arising from a use of `get' +-} + +-} + +-- Encapsulation of effects +-- The example suggested by a reviewer + +{- The reviewer outlined an MTL implementation below, writing + ``This hides the state effect and I can layer another state effect on + top without getting into conflict with the class system.'' + +class Monad m => MonadFresh m where + fresh :: m Int + +newtype FreshT m a = FreshT { unFreshT :: State Int m a } + deriving (Functor, Monad, MonadTrans) + + instance Monad m => MonadFresh (FreshT m) where + fresh = FreshT $ do n <- get; put (n+1); return n + +See EncapsMTL.hs for the complete code. +-} diff --git a/src/Control/Eff/Internal.hs b/src/Control/Eff/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Internal.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + +-- ------------------------------------------------------------------------ +-- | A monadic library for communication between a handler and +-- its client, the administered computation +-- +-- Original work available at . +-- This module implements extensible effects as an alternative to monad transformers, +-- as described in and +-- . +-- +-- 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 where + +import qualified Control.Arrow as A +import qualified Control.Category as C +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import qualified Control.Exception as Exc +import safe Data.OpenUnion +import safe Data.FTCQueue +import GHC.Exts (inline) +import Data.Function (fix) + +-- | Effectful arrow type: a function from a to b that also does effects +-- denoted by r +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 `C.Category' and `A.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 'A.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 [2] singleK #-} +singleK :: Arr r a b -> Arrs r a b +singleK k = Arrs (tsingleton k) +{-# RULES +"singleK/qApp" [~2] forall q. singleK (qApp q) = q + #-} + +-- | Application to the `generalized effectful function' @Arrs r b w@, i.e., +-- convert 'Arrs' to 'Arr' +{-# INLINABLE [2] 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 (Arrs q0) u -> E (Arrs (q0 >< t)) u +{- +-- 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' +{-# INLINE [2] (^$) #-} +(^$) :: forall r b w. Arrs r b w -> b -> Eff r 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 +{-# INLINE comp #-} +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 monad that all effects in this library are based on. +-- +-- An effectful computation is a value of type `Eff r a`. +-- In this signature, @r@ is a type-level list of effects that are being +-- requested and need to be handled inside an effectful computation. +-- @a@ is the computation's result similar to other monads. +-- +-- A computation's result can be retrieved via the 'run' function. +-- However, all effects used in the computation need to be handled by the use +-- of the effects' @run*@ functions before unwrapping the final result. +-- For additional details, see the documentation of the effects you are using. +data Eff r a = Val a + | forall b. E (Arrs r b a) (Union r b) +-- | Case analysis for 'Eff' datatype. If the value is @'Val' a@ apply +-- the first function to @a@; if it is @'E' u q@, apply the second +-- function. +{-# INLINE eff #-} +eff :: (a -> b) + -> (forall v. Arrs r v a -> Union r v -> b) + -> Eff r a -> b +eff f _ (Val a) = f a +eff _ g (E q u) = g q u + +-- | The usual 'bind' fnuction with arguments flipped. This is a +-- common pattern for Eff. +{-# INLINE bind #-} +bind :: Arr r a b -> Eff r a -> Eff r b +bind k e = eff k (E . (^|> k)) e -- just accumulates continuations + +-- | Compose effectful arrows (and possibly change the effect!) +{-# INLINE qComp #-} +qComp :: Arrs r a b -> (Eff r b -> k) -> (a -> k) +-- 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 + +instance Functor (Eff r) where + {-# INLINE fmap #-} + fmap f x = bind (Val . f) x + +instance Applicative (Eff r) where + {-# INLINE pure #-} + pure = Val + mf <*> e = bind (`fmap` e) mf + +instance Monad (Eff r) where + {-# INLINE return #-} + {-# INLINE [2] (>>=) #-} + return = pure + m >>= f = bind f m +{- + Val _ >> m = m + E q u >> m = E (q ^|> const m) u +-} + +-- | 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 (singleK Val) (inj t) +-- This seems to be a very beneficial rule! On micro-benchmarks, cuts +-- the needed memory in half and speeds up almost twice. +{-# RULES + "send/bind" [~3] forall t k. send t >>= k = E (singleK k) (inj t) + #-} + + +-- ------------------------------------------------------------------------ +-- | Get the result from a pure computation +-- +-- A pure computation has type @Eff '[] a@. The empty effect-list indicates that +-- no further effects need to be handled. +run :: Eff '[] w -> w +run (Val x) = x +-- | @Union []@ has no nonbottom values. +-- Due to laziness it is possible to get into this branch but its union argument +-- cannot terminate. +-- To extract the true error, the evaluation of union is forced. +-- 'run' is a total function if its argument is different from bottom. +run (E _ union) = + union `seq` error "extensible-effects: the impossible happened!" + +-- | Abstract the recursive 'relay' pattern, i.e., "somebody else's problem". +class Relay k r where + relay :: (v -> k) -> Union r v -> k +instance Relay (Eff r w) r where + {-# INLINABLE relay #-} + relay q u = E (singleK q) u +instance Relay k r => Relay (s -> k) r where + {-# INLINABLE relay #-} + relay q u s = relay (\x -> q x s) u + +-- | Respond to requests of type @t@. The handlers themselves are expressed in +-- open-recursion style. +class Handle t r a k where + handle :: (Eff r a -> k) -- ^ untied recursive knot + -> Arrs r v a -- ^ coroutine awaiting response + -> t v -- ^ request + -> k + + -- | A convenient pattern: given a request (in an open union), either handle + -- it (using default Handler) or relay it. + -- + -- "Handle" implies that all requests of type @t@ are dealt with, i.e., @k@ + -- (the response type) doesn't have @t@ as part of its effect list. The @Relay + -- k r@ constraint ensures that @k@ is an effectful computation (with + -- effectlist @r@). + -- + -- Note that we can only handle the leftmost effect type (a consequence of the + -- 'Data.OpenUnion' implementation. + handle_relay :: r ~ (t ': r') => Relay k r' + => (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ untied recursive knot + -> Eff r a -> k + handle_relay ret step m = eff ret + (\q u -> case u of + U0 x -> handle step q x + U1 u' -> relay (qComp q step) u') + m + -- | Intercept the request and possibly respond to it, but leave it + -- unhandled. The @Relay k r@ constraint ensures that @k@ is an effectful + -- computation (with effectlist @r@). As such, the effect type @t@ will show + -- up in the response type @k@. There are two natural / commmon options for + -- @k@: the implicit effect domain (i.e., Eff r (f a)), or the explicit effect + -- domain (i.e., s1 -> s2 -> ... -> sn -> Eff r (f a s1 s2 ... sn)). + -- + -- There are three different ways in which we may want to alter behaviour: + -- + -- 1. __Before__: This work should be done before 'respond_relay' is called. + -- + -- 2. __During__: This work should be done by altering the handler being + -- passed to 'respond_relay'. This allows us to modify the requests "in + -- flight". + -- + -- 3. __After__: This work should be done be altering the @ret@ being passed + -- to 'respond_relay'. This allows us to overwrite changes or discard them + -- altogether. If this seems magical, note that we have the flexibility of + -- altering the target domain @k@. Specifically, the explicit domain + -- representation gives us access to the "effect" realm allowing us to + -- manipulate it directly. + respond_relay :: Member t r => Relay k r + => (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ untied recursive knot + -> Eff r a -> k + respond_relay ret step m = eff ret + (\q u -> case u of + U0' x -> handle @t step q x + _ -> relay (qComp q step) u) + m + +-- | A less commonly needed variant with an explicit handler (instead +-- of @Handle t r a k@ constraint). +{-# INLINE handle_relay' #-} +handle_relay' :: r ~ (t ': r') => Relay k r' + => (forall v. (Eff r a -> k) -> Arrs r v a -> t v -> k) -- ^ handler + -> (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ untied recursive knot + -> Eff r a -> k +handle_relay' hdl ret step m = eff ret + (\q u -> case u of + U0 x -> hdl step q x + U1 u' -> relay (qComp q step) u') + m + +-- | Variant with an explicit handler (instead of @Handle t r a k@ +-- constraint). +{-# INLINE respond_relay' #-} +respond_relay' :: Member t r => Relay k r + => (forall v. (Eff r a -> k) -> Arrs r v a -> t v -> k) -- ^ handler + -> (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ recursive knot + -> Eff r a -> k +respond_relay' hdl ret step m = eff ret + (\q u -> case u of + U0' x -> hdl step q x + _ -> relay (qComp q step) u) + m + +-- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to +-- MTL's 'lift'. +raise :: Eff r a -> Eff (e ': r) a +raise (Val x) = pure x +raise (E q u) = E k (U1 u) + where k = qComps q raise +{-# INLINE raise #-} + +-- ------------------------------------------------------------------------ +-- | Lifting: emulating monad transformers +newtype Lift m a = Lift { unLift :: m a } + +-- |A convenient alias to @SetMember Lift (Lift m) r@, which allows us +-- to assert that the lifted type occurs ony once in the effect list. +type Lifted m r = SetMember Lift (Lift m) r + +-- |Same as 'Lifted' but with additional 'MonadBaseControl' constraint +type LiftedBase m r = ( SetMember Lift (Lift m) r + , MonadBaseControl m (Eff r) + ) + +-- | embed an operation of type `m a` into the `Eff` monad when @Lift m@ is in +-- a part of the effect-list. +lift :: Lifted m r => m a -> Eff r a +lift = send . Lift + +-- | Handle lifted requests by running them sequentially +instance Monad m => Handle (Lift m) r a (m k) where + handle step q (Lift x) = x >>= (step . (q ^$)) + +-- | The handler of Lift requests. It is meant to be terminal: we only +-- allow a single Lifted Monad. Note, too, how this is different from +-- other handlers. +runLift :: Monad m => Eff '[Lift m] w -> m w +runLift m = fix step m + where + step :: Monad m => (Eff '[Lift m] w -> m w) -> Eff '[Lift m] w -> m w + step next m' = eff return + (\q u -> case u of + U0' x -> handle next q x + _ -> error "Impossible: Nothing to relay!") + m' + +-- | Catching of dynamic exceptions +-- See the problem in +-- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO +catchDynE :: forall e a r. + (Lifted IO r, Exc.Exception e) => + Eff r a -> (e -> Eff r a) -> Eff r a +catchDynE m eh = fix (respond_relay' h return) m + where + -- Polymorphic local binding: signature is needed + h :: (Eff r a -> Eff r a) -> Arrs r v a -> Lift IO v -> Eff r a + h step q (Lift em) = lift (Exc.try em) >>= either eh k + where k = step . (q ^$) + +-- | You need this when using 'catchesDynE'. +data HandlerDynE r a = + forall e. (Exc.Exception e, Lifted IO r) => HandlerDynE (e -> Eff r a) + +-- | Catch multiple dynamic exceptions. The implementation follows +-- that in Control.Exception almost exactly. Not yet tested. +-- Could this be useful for control with cut? +catchesDynE :: Lifted IO r => Eff r a -> [HandlerDynE r a] -> Eff r a +catchesDynE m hs = m `catchDynE` catchesHandler hs where + catchesHandler :: Lifted IO r => [HandlerDynE r a] -> Exc.SomeException -> Eff r a + catchesHandler handlers e = foldr tryHandler (lift . Exc.throw $ e) handlers + where + tryHandler (HandlerDynE h) res = maybe res h (Exc.fromException e) + +instance (MonadBase b m, Lifted m r) => MonadBase b (Eff r) where + liftBase = lift . liftBase + {-# INLINE liftBase #-} + +instance (MonadBase m m) => MonadBaseControl m (Eff '[Lift m]) where + type StM (Eff '[Lift m]) a = a + liftBaseWith f = lift (f runLift) + {-# INLINE liftBaseWith #-} + restoreM = return + {-# INLINE restoreM #-} + +instance (MonadIO m, Lifted m r) => MonadIO (Eff r) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} diff --git a/src/Control/Eff/Lift.hs b/src/Control/Eff/Lift.hs deleted file mode 100644 --- a/src/Control/Eff/Lift.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} --- | Lifting primitive Monad types to effectful computations. --- We only allow a single Lifted Monad because Monads aren't commutative --- (e.g. Maybe (IO a) is functionally distinct from IO (Maybe a)). -module Control.Eff.Lift( Lift - , lift - , runLift - ) where - -import Control.Eff -import Data.Typeable - --- | Lift a Monad m to an effect. -data Lift m v = forall a. Lift (m a) (a -> v) - -instance Typeable1 m => Typeable1 (Lift m) where - typeOf1 _ = mkTyConApp (mkTyCon3 "" "Eff" "Lift") - [typeOf1 (undefined :: m ())] - -instance Functor (Lift m) where - fmap f (Lift m k) = Lift m (f . k) - -instance SetMember Lift (Lift m) (Lift m :> ()) - --- | Lift a Monad to an Effect. -lift :: (Typeable1 m, Member (Lift m) r, SetMember Lift (Lift m) r) => m a -> Eff r a -lift m = send (inj . Lift m) - --- | The handler of Lift requests. It is meant to be terminal: --- we only allow a single Lifted Monad. -runLift :: (Monad m, Typeable1 m) => Eff (Lift m :> ()) w -> m w -runLift m = loop (admin m) where - loop (Val x) = return x - loop (E u) = prjForce u $ \(Lift m' k) -> m' >>= loop . k diff --git a/src/Control/Eff/Logic/Core.hs b/src/Control/Eff/Logic/Core.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic/Core.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | Logic primitives. See @LogicT@ paper for details. +-- +-- * [@LogicT@] [LogicT - backtracking monad transformer with fair operations and pruning](http://okmij.org/ftp/Computation/monads.html#LogicT) +module Control.Eff.Logic.Core where + +import Control.Monad + +import Control.Eff +import Control.Eff.Exception + +import Data.Function (fix) + +-- | The MSplit primitive from LogicT paper. +class MSplit m where + -- | The laws for 'msplit' are: + -- + -- > msplit mzero = return Nothing + -- > msplit (return a `mplus` m) = return (Just(a, m)) + msplit :: m a -> m (Maybe (a, m a)) + +-- | Embed a pure value into MSplit +{-# INLINE withMSplit #-} +withMSplit :: MonadPlus m => a -> m a -> m (Maybe (a, m a)) +withMSplit a rest = return (Just (a, rest)) +-- The handlers are defined in terms of the specific non-determinism +-- effects (instead of by way of a distinct MSplit handler + +-- | Laws for 'reflect': +-- +-- > msplit (lift m >> mzero) >>= reflect = lift m >> mzero +-- > msplit (lift m `mplus` ma) >>= reflect = lift m `mplus` (msplit ma >>= reflect) +{-# INLINE reflect #-} +reflect :: MonadPlus m => Maybe (a, m a) -> m a +reflect Nothing = mzero +reflect (Just (a,m)) = return a `mplus` m + +-- Other committed choice primitives can be implemented in terms of msplit +-- The following implementations are directly from the LogicT paper + +-- | Soft-cut: non-deterministic if-then-else, aka Prolog's @*->@ +-- Declaratively, +-- +-- > ifte t th el = (t >>= th) `mplus` ((not t) >> el) +-- +-- However, @t@ is evaluated only once. In other words, @ifte t th el@ +-- is equivalent to @t >>= th@ if @t@ has at least one solution. +-- If @t@ fails, @ifte t th el@ is the same as @el@. Laws: +-- +-- > ifte (return a) th el = th a +-- > ifte mzero th el = el +-- > ifte (return a `mplus` m) th el = th a `mplus` (m >>= th) +ifte :: (MonadPlus m, MSplit m) + => m t -> (t -> m b) -> m b -> m b +ifte t th el = msplit t >>= check + where check Nothing = el + check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th) + +-- | Another pruning operation (ifte is the other). This selects one +-- solution out of possibly many. +once :: (MSplit m, MonadPlus m) => m b -> m b +once m = msplit m >>= check + where check Nothing = mzero + check (Just (sg1,_)) = return sg1 + +-- | Negation as failure +gnot :: (MonadPlus m, MSplit m) => m b -> m () +gnot m = ifte (once m) (const mzero) (return ()) + +-- | Fair (i.e., avoids starvation) disjunction. It obeys the +-- following laws: +-- +-- > interleave mzero m = m +-- > interleave (return a `mplus` m1) m2 = return a `mplus` (interleave m2 m1) +-- +-- corollary: +-- +-- > interleave m mzero = m +interleave :: (MSplit m, MonadPlus m) => m b -> m b -> m b +interleave sg1 sg2 = + do r <- msplit sg1 + case r of + Nothing -> sg2 + Just (sg11,sg12) -> + (return sg11) `mplus` (interleave sg2 sg12) + +-- | Fair (i.e., avoids starvation) conjunction. It obeys the +-- following laws: +-- +-- > mzero >>- k = mzero +-- > (return a `mplus` m) >>- k = interleave (k a) (m >>- k) +(>>-) :: (MonadPlus m, MSplit m) => m a -> (a -> m b) -> m b +sg >>- g = + do r <- msplit sg + case r of + Nothing -> mzero + Just (sg1 ,sg2) -> interleave (g sg1) (sg2 >>- g) + +-- | Collect all solutions. This is from Hinze's @Backtr@ monad +-- class. Unsurprisingly, this can be implemented in terms of msplit. +sols :: (Monad m, MSplit m) => m a -> m [a] +sols m = (msplit m) >>= (fix step) [] where + step _ jq Nothing = return jq + step next jq (Just(a, ma)) = (msplit ma) >>= next (a:jq) + +-- | Non-determinism with control (@cut@). +-- +-- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper: +-- +-- * [@Backtr@] [Deriving Backtracking Monad Transformers](https://dl.acm.org/citation.cfm?id=351240.351258) +-- +-- Hinze suggests expressing @cut@ in terms of @cutfalse@: +-- +-- > = return () `mplus` cutfalse +-- > where +-- > cutfalse :: m a +-- +-- satisfies the following laws: +-- +-- > cutfalse >>= k = cutfalse (F1) +-- > cutfalse | m = cutfalse (F2) +-- +-- (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@). +-- In other words, cutfalse is the left zero of both bind and mplus. +-- +-- Hinze also introduces the operation @`call` :: m a -> m a@ that +-- delimits the effect of cut: @`call` m@ executes m. If the cut is +-- invoked in m, it discards only the choices made since m was called. +-- Hinze postulates the axioms of `call`: +-- +-- > call false = false (C1) +-- > call (return a | m) = return a | call m (C2) +-- > call (m | cutfalse) = call m (C3) +-- > call (lift m >>= k) = lift m >>= (call . k) (C4) +-- +-- @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect, +-- he says. +-- +-- Hinze noted a problem with the \"mechanical\" derivation of backtracing +-- monad transformer with cut: no axiom specifying the interaction of +-- call with bind; no way to simplify nested invocations of call. +class Call r where + -- | Mapping @Backtr@ interface to 'MonadPlus' and using exceptions for + -- @cutfalse@, every instance should ensure that the following laws hold: + -- + -- > cutfalse `mplus` m = cutfalse --(F2) + -- > call mzero = mzero --(C1) + -- > call (return a `mplus` m) = return a `mplus` call m --(C2) + -- > call (m `mplus` cutfalse) = call m --(C3) + -- > call (lift m >>= k) = lift m >>= (call . k) --(C4) + call :: MonadPlus (Eff r) => Eff (Exc CutFalse : r) a -> Eff r a + +data CutFalse = CutFalse + +-- | We use exceptions for cutfalse +-- Therefore, the law @cutfalse >>= k = cutfalse@ +-- is satisfied automatically since all exceptions have the above property. +cutfalse :: Member (Exc CutFalse) r => Eff r a +cutfalse = throwError CutFalse + +-- | Prolog @cut@, taken from Hinze 2000 (Deriving backtracking monad +-- transformers). +(!) :: (Member (Exc CutFalse) r, MonadPlus (Eff r)) => Eff r () +(!) = return () `mplus` cutfalse + +-- | Case analysis for lists +{-# INLINE list #-} +list :: b -> (a -> [a] -> b) + -> [a] -> b +list z _ [] = z +list _ k (h:t) = k h t diff --git a/src/Control/Eff/Logic/Experimental.hs b/src/Control/Eff/Logic/Experimental.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic/Experimental.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module is for some experimental implementations and tinkering. Not +-- intended to be exposed or depended on. +module Control.Eff.Logic.Experimental where + +import Control.Eff +import Control.Eff.Extend +import Control.Eff.Exception +import Control.Eff.Logic.Core +import Control.Monad + +instance (MonadPlus (Eff (Exc CutFalse : r)), MSplit (Eff (Exc CutFalse : r))) + => Call r where + call m = loop m [] where + loop m' jq = case msplit m' of + Val Nothing -> next jq -- (C1) + Val (Just (x, q)) -> return x `mplus` next (q : jq) -- (C2) + E q u -> case u of + U0 (Exc CutFalse) -> next [] -- drop jq (F2) + U1 _ -> loop (E q u >>= reflect) jq -- (C4?) + --_ -> loop m' jq + next jq = list mzero loop jq -- (C3?) + {- + call m = loop (msplit m) [] where + loop (Val Nothing) jq = next jq -- (C1) + loop (Val (Just (x, q))) jq = return x `mplus` next (q : jq) -- (C2) + loop (E q u) jq = case u of + U0 (Exc CutFalse) -> next [] -- drop jq (F2) + _ -> loop (E q u) jq -- (C4?) + + next [] = mzero + next (h:t) = loop (msplit h) t -- (C3?) + -} diff --git a/src/Control/Eff/Logic/NDet.hs b/src/Control/Eff/Logic/NDet.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic/NDet.hs @@ -0,0 +1,229 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE Safe #-} +-- The following is needed to define MonadPlus instance. It is decidable +-- (there is no recursion!), but GHC cannot see that. +{-# LANGUAGE UndecidableInstances #-} +-- The following is needed for pattern-synonym bug in ghc 8.2 +{-# LANGUAGE CPP #-} + +-- | Nondeterministic choice effect via MPlus interface directly. In order to +-- get an understanding of what nondeterministic choice entails the following +-- papers are recommended: +-- +-- * [@LogicT@] [LogicT - backtracking monad transformer with fair operations and pruning](http://okmij.org/ftp/Computation/monads.html#LogicT) +-- * [@Backtr@] [Deriving Backtracking Monad Transformers](https://dl.acm.org/citation.cfm?id=351240.351258) +-- +-- __TODO__: investigate Fusion regd msplit and associated functions. +module Control.Eff.Logic.NDet ( + -- * Main interface + NDet + , withNDet + , left, right + , choose + , makeChoice + , makeChoiceA + , module Control.Eff.Logic.Core + -- * Additional functions for comparison + , msplit' + , msplit'_manual + , makeChoiceA_manual + , makeChoiceA0 + ) where + +import Control.Eff +import Control.Eff.Extend +import Control.Eff.Logic.Core +import Control.Eff.Exception + +import Control.Applicative +import Control.Monad +import Control.Monad.Base +import Control.Monad.Trans.Control +import Data.Function (fix) + +-- | An implementation of non-deterministic choice aka backtracking. The two +-- requests we need to support are: @false@, @(|)@. We map this to the +-- 'MonadPlus' (or 'Alternative') interface: @MZero@ stands for @false@, and +-- @MPlus@ stands for @(|)@. +-- +-- This creates a branching structure with a fanout of @2@, resulting in @mplus@ +-- node being visited approximately @2x@ (in general, for a fanout of @f@ we'll +-- have the type of internal node being invoked @f/(f-1)@ times). +data NDet a where + MZero :: NDet a + MPlus :: NDet Bool + +-- | How to embed a pure value in non-deterministic context +{-# INLINE withNDet #-} +withNDet :: Alternative f => Monad m => a -> m (f a) +withNDet x = return (pure x) +-- | The left branch +{-# INLINE left #-} +left :: Arrs r Bool a -> Eff r a +left q = q ^$ True +-- | The right branch +{-# INLINE right #-} +right :: Arrs r Bool a -> Eff r a +right q = q ^$ False +-- | Given a callback and 'NDet' requests respond to them. Note that this makes +-- explicit that we rely on @f@ to have enough room to store all possibilities. +instance Alternative f => Handle NDet r a (Eff r' (f w)) where + handle _ _ MZero = return empty + handle step q MPlus = liftM2 (<|>) (step $ left q) (step $ right q) + +instance Member NDet r => Alternative (Eff r) where + empty = mzero + (<|>) = mplus + +-- | Mapping of 'NDet' requests to 'MonadPlus'. We obey the following laws +-- (taken from the @Backtr@ and @LogicT papers): +-- +-- > mzero >>= f = mzero -- (L1) +-- > mzero `mplus` m = m -- (L2) +-- > m `mplus` mzero = m -- (L3) +-- > m `mplus` (n `mplus` o) = (m `mplus` n) `mplus` o -- (L4) +-- > (m `mplus` n) >>= k = (m >>= k) `mplus` (n >>= k) -- (L5) +-- +-- - @L1@ is the left-zero law for 'mzero' +-- - @L2, L3, L4@ are the @Monoid@ laws +-- +-- __NOTE__ that we do __not__ obey the right-zero law for +-- 'mzero'. Specifically, we do __not__ obey: +-- +-- > m >> mzero = mzero +instance Member NDet r => MonadPlus (Eff r) where + mzero = send MZero + -- | Applying L2 and L3 +#if __GLASGOW_HASKELL__ < 804 + mplus (E _ u) m2 | Just MZero <- prj u = m2 + mplus m1 (E _ u) | Just MZero <- prj u = m1 +#else + mplus (E _ (U0' MZero)) m2 = m2 + mplus m1 (E _ (U0' MZero)) = m1 +#endif + mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2 + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (NDet ': r)) where + type StM (Eff (NDet ': r)) a = StM (Eff r) [a] + liftBaseWith f = raise $ liftBaseWith $ \runInBase -> + f (runInBase . makeChoice) + restoreM x = do lst :: [a] <- raise (restoreM x) + choose lst + +-- | @'choose' lst@ non-deterministically chooses one value from the +-- @lst@. @'choose' []@ thus corresponds to failure. +choose :: Member NDet r => [a] -> Eff r a +choose lst = msum $ map return lst + +-- | An interpreter: The following is very simple, but leaks a lot of memory The +-- cause probably is mapping every failure to empty It takes then a lot of timne +-- and space to store those empty. When there aren't a lot of failures, this is +-- comparable to 'makeChoiceA'. +makeChoiceA0 :: Alternative f => Eff (NDet ': r) a -> Eff r (f a) +makeChoiceA0 = fix (handle_relay withNDet) + +-- | More performant handler; uses reified job queue +instance Alternative f => Handle NDet r a ([Eff r a] -> Eff r' (f w)) where + handle step _ MZero jq = next step jq + handle step q MPlus jq = next step (left q : right q : jq) +-- instance Handle NDet r a (k -> [Eff r a] -> k) where +-- handle step _ MZero z jq = list z (flip step z) jq +-- handle step q MPlus z jq = list z (flip step z) (left q : right q : jq) + +{-# INLINE next #-} +-- | Progressing the cursor in a reified job queue. +next :: Alternative f => Monad m + => (t -> [t] -> m (f a)) + -> [t] -> m (f a) +next k jq = list (return empty) k jq + +-- | Optimized implementation, faster and taking less memory. The benefit of the +-- effect framework is that we can have many interpreters. +makeChoiceA :: Alternative f => Eff (NDet ': r) a -> Eff r (f a) +makeChoiceA m' = loop m' [] where + loop m = fix (handle_relay @NDet ret) m + -- single result; optimization: drop spurious empty + ret x [] = withNDet x + -- definite result and perhaps some others + ret x (h:t) = liftM2 (<|>) (withNDet x) (loop h t) + +-- | A different implementation, more involved, but similar complexity to +-- 'makeChoiceA'. +makeChoiceA_manual :: Alternative f => Eff (NDet ': r) a -> Eff r (f a) +makeChoiceA_manual m = loop m [] where + -- single result; optimization: drop spurious empty + loop (Val x) [] = withNDet x + -- definite result and perhaps some others + loop (Val x) (h:t) = liftM2 (<|>) (withNDet x) (loop h t) + loop (E q u) jq = case decomp u of + Right MZero -> next loop jq + Right MPlus -> loop (k True) (k False : jq) + Left u0 -> relay (loop . k) u0 jq + where + k = (q ^$) + +-- | Same as 'makeChoiceA', except it has the type hardcoded. +-- Required for 'MonadBaseControl' instance. +makeChoice :: Eff (NDet ': r) a -> Eff r [a] +makeChoice = makeChoiceA + +-- | We implement LogicT, the non-determinism reflection, of which soft-cut is +-- one instance. See the LogicT paper for an explanation. +instance Member NDet r => MSplit (Eff r) where + msplit = msplit' + +-- | The implementation of 'MSplit'. Exported as a standalone to make +-- testing/comparison easier. +{-# INLINE msplit' #-} +msplit' :: Member NDet r => Eff r a -> Eff r (Maybe (a, Eff r a)) +msplit' m = fix (respond_relay @NDet (\x jq -> withMSplit x (msum jq))) m [] + +-- | A different implementation, more involved, but similar complexity to +-- 'msplit''. +{-# INLINE msplit'_manual #-} +msplit'_manual :: Member NDet r => Eff r a -> Eff r (Maybe (a, Eff r a)) +msplit'_manual m' = loop m' [] where + -- definite result and perhaps some others + loop (Val x) jq = withMSplit x (msum jq) + -- not yet definite answer + loop (E q u) jq = case u of + -- try other choices, if any + U0' MZero -> next loop jq + -- try left options; add right to job queue + U0' MPlus -> loop (k True) (k False : jq) + _ -> relay (loop . k) u jq + where + k x = q ^$ x + +-- | The call interpreter -- it is like reify . reflect with a twist. Compare +-- this implementation with the huge implementation of call in Hinze 2000 +-- (Figure 9). Each clause corresponds to the axiom of call or cutfalse. All +-- axioms are covered. +-- +-- The code clearly expresses the intuition that call watches the choice points +-- of its argument computation. When it encounteres a cutfalse request, it +-- discards the remaining choicepoints. It completely handles CutFalse effects +-- but not non-determinism +instance Member NDet r => Call r where + call m = loop m [] where + loop (Val x) jq = return x `mplus` nxt jq -- (C2) + loop (E _ (U0 (Exc CutFalse))) _ = nxt [] -- drop jq (F2) + loop (E q (U1 u)) jq = case u of + U0' MZero -> nxt jq -- (C1) + U0' MPlus -> nxt (left q : right q : jq) -- (C3) + _ -> relay (loop . (q ^$)) u jq -- (C4) + + nxt jq = list mzero loop jq diff --git a/src/Control/Eff/Operational.hs b/src/Control/Eff/Operational.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Operational.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} + +-- | Operational Monad () implemented with +-- extensible effects. + +module Control.Eff.Operational ( Program (..) + , withOperational, Intrprtr (..) + , singleton + , runProgram + -- * Usage + -- $usage + ) where + +import Control.Eff as E +import Control.Eff.Extend + +import Data.Function (fix) + +-- | Lift values to an effect. +-- You can think this is a generalization of @Lift@. +data Program instr v where + Singleton :: instr a -> Program instr a + +-- | General form of an interpreter +newtype Intrprtr f r = Intrprtr { runIntrprtr :: forall x. f x -> Eff r x } + +-- | Embed a pure value +withOperational :: a -> Intrprtr f r -> Eff r a +withOperational x _ = return x +-- | Given a continuation and a program, interpret it +-- Usually, we have @r ~ [Program f : r']@ +instance Handle (Program f) r a (Intrprtr f r' -> Eff r' a) where + handle step q (Singleton instr) i = (runIntrprtr i) instr >>= + \x -> step (q ^$ x) i + +-- | Lift a value to a monad. +singleton :: (Member (Program instr) r) => instr a -> Eff r a +singleton = send . Singleton + +-- | Convert values using given interpreter to effects. +runProgram :: forall f r a. (forall x. f x -> Eff r x) -> Eff (Program f ': r) a -> Eff r a +runProgram advent m = fix (handle_relay withOperational) m (Intrprtr advent) + +-- $usage +-- +-- See "Control.Eff.Operational.Example" for an example of defining data using +-- GADTs and implementing interpreters from the data to effects. +-- +-- To use the interpreter, see below or consult the tests. +-- +-- @ +--main :: IO () +--main = do +-- let comp = 'runProgram' adventPure prog +-- putStrLn . fst . 'run' . 'E.Writer.Strict.runMonoidWriter' $ 'E.State.Strict.evalState' comp [\"foo\",\"bar\"] +-- 'runLift' $ 'runProgram' adventIO prog +-- @ diff --git a/src/Control/Eff/Operational/Example.hs b/src/Control/Eff/Operational/Example.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Operational/Example.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} + +-- | Example usage of "Control.Eff.Operational". +module Control.Eff.Operational.Example where + +import Control.Eff.Operational +import Control.Eff +import Control.Eff.Writer.Lazy +import Control.Eff.State.Lazy + +-- | Define data using GADTs. +data Jail a where + Print :: String -> Jail () + Scan :: Jail String + +prog :: Member (Program Jail) r => Eff r () +prog = do + singleton $ Print "getting input..." + str <- singleton Scan + singleton $ Print "ok" + singleton $ Print ("the input is " ++ str) + +-- | Then, implements interpreters from the data to effects. +adventIO :: Lifted IO r => Jail a -> Eff r a +adventIO (Print a) = lift $ putStrLn a +adventIO Scan = lift getLine + +adventPure :: [ Writer String, State [String] ] <:: r => Jail a -> Eff r a +adventPure (Print a) = tell (a ++ "\n") +adventPure Scan = do + x <- get + case x of + [] -> return [] + y:ys -> put ys >> return y diff --git a/src/Control/Eff/QuickStart.hs b/src/Control/Eff/QuickStart.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/QuickStart.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} + +-- | This module contains several tiny examples of how to use effects. +-- For technical details, see the documentation in the effect-modules. +-- +-- Note that most examples given here are very small. For them, +-- using `Eff` monad is more complicated compared to a standard functional +-- approach. +-- The power of extensible effects lie in the fact that these computations can +-- be used to construct much more complicated programs by composing the little +-- pieces shown here. +-- +-- This module imports and reexports modules from this library and requires +-- some language extensions: +-- +-- @ +-- {-\# LANGUAGE ScopedTypeVariables \#-} +-- {-\# LANGUAGE FlexibleContexts \#-} +-- {-\# LANGUAGE MonoLocalBinds \#-} +-- +-- import Control.Eff +-- import Control.Eff.Reader.Lazy +-- import Control.Eff.Writer.Lazy +-- import Control.Eff.State.Lazy +-- import Control.Eff.Exception +-- @ +-- +-- If you want to see what each extension is good for, you can disable it and +-- see what GHC will complain about. +-- +module Control.Eff.QuickStart + ( -- * Examples + module Control.Eff.QuickStart + -- * Imported effect modules + , module Control.Eff.Reader.Lazy + , module Control.Eff.State.Lazy + , module Control.Eff.Exception + ) where + +import Control.Eff +import Control.Eff.Reader.Lazy +import Control.Eff.State.Lazy +import Control.Eff.Exception +import Control.Monad ( when ) + +-- | an effectful function that can throw an error +-- +-- @ +-- tooBig i = do +-- when (i > 100) $ throwError $ show i +-- return i +-- @ +tooBig :: Member (Exc String) r => Int -> Eff r Int +tooBig i = do + when (i > 100) $ throwError $ show i + return i + +-- | run the @tooBig@ effect based on a provided Int. +-- +-- @ +-- runTooBig i = run . runError $ tooBig i +-- @ +-- +-- >>> runTooBig 1 +-- Right 1 +-- +-- >>> runTooBig 200 +-- Left "200" +runTooBig :: Int -> Either String Int +runTooBig i = run . runError $ tooBig i + +-- | an effectul computation using state. The state is of type @[Int]@. +-- This function takes the head off the list, if it is there and return it. +-- If state is the empty list, then it stays the same and returns @Nothing@. +-- +-- @ +-- popState = do +-- stack <- get +-- case stack of +-- [] -> return Nothing +-- (x : xs) -> do +-- put xs +-- return $ Just x +-- @ +popState :: Member (State [Int]) r => Eff r (Maybe Int) +popState = do + stack <- get + case stack of + [] -> return Nothing + (x : xs) -> do + put xs + return $ Just x + +-- | run the popState effectful computation based on initial state. The +-- result-type is the result of the computation @Maybe Int@ together with the +-- state at the end of the computation @[Int]@ +-- +-- @ +-- runPopState xs = run . runState xs $ popState +-- @ +-- +-- >>> runPopState [1, 2, 3] +-- (Just 1,[2,3]) +-- +-- >>> runPopState [] +-- (Nothing,[]) +runPopState :: [Int] -> (Maybe Int, [Int]) +runPopState xs = run . runState xs $ popState + +-- | an effect that returns a number one more than the given +-- +-- @ +-- oneMore = do +-- x <- ask -- query the environment +-- return $ x + 1 -- add one to the asked value and return it +-- @ +oneMore :: Member (Reader Int) r => Eff r Int +oneMore = do + x <- ask + return $ x + 1 + +-- | Run the @oneMore@ effectful function by giving it a value to read. +-- +-- @ +-- runOneMore i = run . runReader i $ oneMore +-- @ +-- +-- >>> runOneMore 1 +-- 2 +runOneMore :: Int -> Int +runOneMore i = run . runReader i $ oneMore + +-- | An effectful computation with multiple effects: +-- +-- * A value gets read +-- * an error can be thrown depending on the read value +-- * state gets read and transformed +-- +-- All these effects are composed using the @Eff@ monad using the corresponding +-- Effect types. +-- +-- @ +-- something = do +-- readValue :: Float <- ask -- read a value from the environment +-- when (readValue < 0) $ throwError readValue -- if the value is negative, throw an error +-- modify (\l -> (round readValue :: Integer) : l) -- add the rounded read element to the list +-- currentState :: [Integer] <- get -- get the state after the modification +-- return $ sum currentState -- sum the elements in the list and return that +-- @ +something + :: (Member (Reader Float) r, Member (State [Integer]) r, Member (Exc Float) r) + => Eff r Integer +something = do + readValue :: Float <- ask + when (readValue < 0) $ throwError readValue + modify (\l -> (round readValue :: Integer) : l) + currentState :: [Integer] <- get + return $ sum currentState + +-- | Run the @someting@ effectful computation given in the previous function. +-- The handlers apply from bottom to top - so this is the reading direction. +-- +-- @ +-- runSomething1 initialState newValue = +-- run . -- run the Eff-monad with no effects left +-- runError . -- run the error part of the effect. This introduces the Either in the result. +-- runState initialState . -- handle the state-effect providing an initial state giving back a pair. +-- runReader newValue $ -- provide the computation with the dynamic value to read/ask for +-- something -- the computation - function +-- @ +-- +-- >>> runSomething1 [] (-0.5) +-- Left (-0.5) +-- +-- >>> runSomething1 [2] 1.3 +-- Right (3,[1,2]) +runSomething1 :: [Integer] -> Float -> Either Float (Integer, [Integer]) +runSomething1 initialState newValue = + run . runError . runState initialState . runReader newValue $ something + +-- | Run the @something@ effectful computation given above. +-- This has an alternative ordering of the effect-handlers. +-- +-- The used effect-handlers are the same are used in slightly different order: +-- The @runState@ and @runError@ methods are swapped, which results in a +-- different output type and run-semantics. +-- +-- @ +-- runSomething1 initialState newValue = +-- run . +-- runState initialState . +-- runError . +-- runReader newValue $ +-- something -- the computation - function +-- @ +-- +-- >>> runSomething2 [4] (-2.4) +-- (Left (-2.4),[4]) +-- +-- >>> runSomething2 [4] 5.9 +-- (Right 10,[6,4]) +runSomething2 :: [Integer] -> Float -> (Either Float Integer, [Integer]) +runSomething2 initialState newValue = + run . runState initialState . runError . runReader newValue $ something diff --git a/src/Control/Eff/Reader/Lazy.hs b/src/Control/Eff/Reader/Lazy.hs --- a/src/Control/Eff/Reader/Lazy.hs +++ b/src/Control/Eff/Reader/Lazy.hs @@ -1,50 +1,90 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeApplications #-} -- | Lazy read-only state -module Control.Eff.Reader.Lazy( Reader +module Control.Eff.Reader.Lazy ( Reader (..) + , withReader , ask , local , reader , runReader ) where -import Control.Applicative ((<$>)) -import Data.Typeable - import Control.Eff +import Control.Eff.Extend --- | The request for a value of type e from the current environment. --- This environment is analogous to a parameter of type e. -newtype Reader e v = Reader (e -> v) - deriving (Typeable, Functor) +import Control.Monad.Base +import Control.Monad.Trans.Control +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | The Reader monad +-- +-- The request for a value of type e from the current environment +-- This can be expressed as a GADT because the type of values +-- returned in response to a (Reader e a) request is not any a; +-- we expect in reply the value of type @e@, the value from the +-- environment. So, the return type is restricted: 'a ~ e' +data Reader e v where + Ask :: Reader e e +-- ^ +-- One can also define this as +-- +-- @ +-- data Reader e v = (e ~ v) => Reader +-- @ +-- ^ without GADTs, using explicit coercion as is done here. +-- +-- @ +-- newtype Reader e v = Reader (e->v) +-- @ +-- ^ In the latter case, when we make the request, we make it as Reader id. +-- So, strictly speaking, GADTs are not really necessary. + +-- | How to interpret a pure value in a reader context +withReader :: Monad m => a -> e -> m a +withReader x _ = return x +-- | Given a value to read, and a callback, how to respond to +-- requests. +instance Handle (Reader e) r a (e -> k) where + handle step q Ask e = step (q ^$ e) e + -- | Get the current value from a Reader. -ask :: (Typeable e, Member (Reader e) r) => Eff r e -ask = send (inj . Reader) +-- The signature is inferred (when using NoMonomorphismRestriction). +ask :: (Member (Reader e) r) => Eff r e +ask = send Ask --- | Locally rebind the value in the dynamic environment. --- This function both requests and admins Reader requests. -local :: (Typeable e, Member (Reader e) r) - => (e -> e) - -> Eff r a - -> Eff r a +-- | The handler of Reader requests. The return type shows that all Reader +-- requests are fully handled. +runReader :: forall e r w. e -> Eff (Reader e ': r) w -> Eff r w +runReader e m = fix (handle_relay withReader) m e + +-- | Locally rebind the value in the dynamic environment This function is like a +-- relay; it is both an admin for Reader requests, and a requestor of them. +local :: forall e a r. Member (Reader e) r => + (e -> e) -> Eff r a -> 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)) - loop (admin m) + e <- reader f + (fix (respond_relay @(Reader e) withReader)) m e + -- note similarity between 'local' and 'State.Lazy.transactionState' -- | Request the environment value using a transformation function. -reader :: (Typeable e, Member (Reader e) r) => (e -> a) -> Eff r a -reader f = f <$> ask +reader :: (Member (Reader e) r) => (e -> a) -> Eff r a +reader f = f `fmap` ask --- | The handler of Reader requests. The return type shows that --- all Reader requests are fully handled. -runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w -runReader m e = loop (admin m) - where - loop (Val x) = return x - loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e)) +instance ( MonadBase m m + , LiftedBase m s + ) => MonadBaseControl m (Eff (Reader e ': s)) where + type StM (Eff (Reader e ': s)) a = StM (Eff s) a + liftBaseWith f = do e <- ask + raise $ liftBaseWith $ \runInBase -> + f (runInBase . runReader e) + restoreM = raise . restoreM diff --git a/src/Control/Eff/Reader/Strict.hs b/src/Control/Eff/Reader/Strict.hs --- a/src/Control/Eff/Reader/Strict.hs +++ b/src/Control/Eff/Reader/Strict.hs @@ -1,50 +1,91 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE Safe #-} -- | Strict read-only state -module Control.Eff.Reader.Strict( Reader - , ask - , local - , reader - , runReader - ) where - -import Control.Applicative ((<$>)) -import Data.Typeable +module Control.Eff.Reader.Strict ( Reader (..) + , withReader + , ask + , local + , reader + , runReader + ) where import Control.Eff +import Control.Eff.Extend --- | The request for a value of type e from the current environment. --- This environment is analogous to a parameter of type e. -newtype Reader e v = Reader (e -> v) - deriving (Typeable, Functor) +import Control.Monad.Base +import Control.Monad.Trans.Control +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | The Reader monad +-- +-- The request for a value of type e from the current environment +-- This can be expressed as a GADT because the type of values +-- returned in response to a (Reader e a) request is not any a; +-- we expect in reply the value of type @e@, the value from the +-- environment. So, the return type is restricted: 'a ~ e' +data Reader e v where + Ask :: Reader e e +-- ^ +-- One can also define this as +-- +-- @ +-- data Reader e v = (e ~ v) => Reader +-- @ +-- ^ without GADTs, using explicit coercion as is done here. +-- +-- @ +-- newtype Reader e v = Reader (e->v) +-- @ +-- ^ In the latter case, when we make the request, we make it as Reader id. +-- So, strictly speaking, GADTs are not really necessary. + +-- | How to interpret a pure value in a reader context +withReader :: Monad m => a -> e -> m a +withReader x _ = return x +-- | Given a value to read, and a callback, how to respond to +-- requests. +instance Handle (Reader e) r a (e -> k) where + handle step q Ask e = step (q ^$ e) e + -- | Get the current value from a Reader. -ask :: (Typeable e, Member (Reader e) r) => Eff r e -ask = send (inj . Reader) +-- The signature is inferred (when using NoMonomorphismRestriction). +ask :: (Member (Reader e) r) => Eff r e +ask = send Ask --- | Locally rebind the value in the dynamic environment. --- This function both requests and admins Reader requests. -local :: (Typeable e, Member (Reader e) r) - => (e -> e) - -> Eff r a - -> Eff r a +-- | The handler of Reader requests. The return type shows that all Reader +-- requests are fully handled. +runReader :: e -> Eff (Reader e ': r) w -> Eff r w +runReader !e m = fix (handle_relay withReader) m e + +-- | Locally rebind the value in the dynamic environment This function is like a +-- relay; it is both an admin for Reader requests, and a requestor of them. +local :: forall e a r. Member (Reader e) r => + (e -> e) -> Eff r a -> 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)) - loop (admin m) + e <- reader f + (fix (respond_relay @(Reader e) withReader)) m e + -- note similarity between 'local' and 'State.Strict.transactionState' -- | Request the environment value using a transformation function. -reader :: (Typeable e, Member (Reader e) r) => (e -> a) -> Eff r a -reader f = f <$> ask +reader :: (Member (Reader e) r) => (e -> a) -> Eff r a +reader f = f `fmap` ask --- | The handler of Reader requests. The return type shows that --- all Reader requests are fully handled. -runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w -runReader m !e = loop (admin m) where - loop (Val x) = return x - loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e)) +instance ( MonadBase m m + , LiftedBase m s + ) => MonadBaseControl m (Eff (Reader e ': s)) where + type StM (Eff (Reader e ': s)) a = StM (Eff s) a + liftBaseWith f = do !e <- ask + raise $ liftBaseWith $ \runInBase -> + f (runInBase . runReader e) + restoreM = raise . restoreM diff --git a/src/Control/Eff/State/Lazy.hs b/src/Control/Eff/State/Lazy.hs --- a/src/Control/Eff/State/Lazy.hs +++ b/src/Control/Eff/State/Lazy.hs @@ -1,54 +1,141 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} -- | Lazy state effect -module Control.Eff.State.Lazy( State - , get - , put - , modify - , runState - , evalState - , execState - ) where - -import Data.Typeable +module Control.Eff.State.Lazy where import Control.Eff +import Control.Eff.Extend --- | Strict state effect -data State s w = State (s -> s) (s -> w) - deriving (Typeable, Functor) +import Control.Eff.Writer.Lazy +import Control.Eff.Reader.Lazy +import Control.Monad.Base +import Control.Monad.Trans.Control + +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | State, lazy +-- +-- Initial design: +-- The state request carries with it the state mutator function +-- We can use this request both for mutating and getting the state. +-- But see below for a better design! +-- +-- > data State s v where +-- > State :: (s->s) -> State s s +-- +-- In this old design, we have assumed that the dominant operation is +-- modify. Perhaps this is not wise. Often, the reader is most nominant. +-- +-- See also below, for decomposing the State into Reader and Writer! +-- +-- The conventional design of State +data State s v where + Get :: State s s + Put :: s -> State s () + +-- | Embed a pure value in a stateful computation, i.e., given an +-- initial state, how to interpret a pure value in a stateful +-- computation. +withState :: Monad m => a -> s -> m (a, s) +withState x s = return (x, s) + +-- | Handle 'State s' requests +instance Handle (State s) r a (s -> k) where + handle step q sreq s = case sreq of + Get -> step (q ^$ s) s + Put s' -> step (q ^$ ()) s' + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (State s ': r)) where + type StM (Eff (State s ': r)) a = StM (Eff r) (a,s) + liftBaseWith f = do s <- get + raise $ liftBaseWith $ \runInBase -> + f (runInBase . runState 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 #-} +get :: Member (State s) r => Eff r s +get = send Get +{-# RULES + "get/bind" forall k. get >>= k = send Get >>= k + #-} + -- | Write a new value of the state. -put :: (Typeable e, Member (State e) r) => e -> Eff r () -put = modify . const +{-# NOINLINE put #-} +put :: Member (State s) r => s -> Eff r () +put s = send (Put s) +{-# RULES + "put/bind" forall k v. put v >>= k = send (Put v) >>= k + #-} +{-# RULES + "put/semibind" forall k v. put v >> k = send (Put v) >>= (\() -> k) + #-} +-- The purpose of the rules is to expose send, which is then being +-- fuzed by the send/bind rule. The send/bind rule is very profitable! +-- These rules are essentially inlining of get/put. Somehow GHC does not +-- inline get/put, even if I put the INLINE directives and play with phases. +-- (Inlining works if I use 'inline' explicitly). --- | Return the current value of the state. -get :: (Typeable e, Member (State e) r) => Eff r e -get = send (inj . State id) +-- | Run a State effect +runState :: s -- ^ Initial state + -> Eff (State s ': r) a -- ^ Effect incorporating State + -> Eff r (a, s) -- ^ Effect containing final state and a return value +runState s m = fix (handle_relay withState) m s -- | Transform the state with a function. -modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r () -modify f = send $ \k -> inj $ State f $ \_ -> k () - --- | Run a State effect. -runState :: Typeable s - => s -- ^ Initial state - -> Eff (State s :> r) w -- ^ Effect incorporating State - -> Eff r (s, w) -- ^ Effect containing final state and a return value -runState s0 = loop s0 . admin where - loop s (Val x) = return (s, x) - loop s (E u) = handleRelay u (loop s) $ - \(State t k) -> let s' = t s - in loop s' (k s') +modify :: (Member (State s) r) => (s -> s) -> Eff r () +modify f = get >>= put . f -- | Run a State effect, discarding the final state. -evalState :: Typeable s => s -> Eff (State s :> r) w -> Eff r w -evalState s = fmap snd . runState s +evalState :: s -> Eff (State s ': r) a -> Eff r a +evalState s = fmap fst . runState s -- | Run a State effect and return the final state. -execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s -execState s = fmap fst . runState s +execState :: s -> Eff (State s ': r) a -> Eff r s +execState s = fmap snd . runState s + +-- | An encapsulated State handler, for transactional semantics +-- The global state is updated only if the transactionState finished +-- successfully +data TxState s v where + TxState :: TxState s s +type TxStateT s = TxState s s + +-- | Embed Transactional semantics to a stateful computation. +withTxState :: Member (State s) r => a -> s -> Eff r a +withTxState x s = put s >> return x + +-- | Confer transactional semantics on a stateful computation. +transactionState :: forall s r a. Member (State s) r + => TxStateT s -> Eff r a -> Eff r a +transactionState _ m = do + s <- get + (fix $ respond_relay @(State s) (withTxState @s)) m s + +-- | A different representation of State: decomposing State into mutation +-- (Writer) and Reading. We don't define any new effects: we just handle the +-- existing ones. Thus we define a handler for two effects together. +runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) +runStateR = flip loop + where + loop :: Eff (Writer s ': Reader s ': r) a -> s -> Eff r (a, s) + loop (Val x) = withState x + loop (E q u) = case u of + U0 (Tell w) -> handle loop q (Put w) + U1 (U0 Ask) -> handle loop q Get + U1 (U1 u') -> relay (qComp q loop) u' diff --git a/src/Control/Eff/State/OnDemand.hs b/src/Control/Eff/State/OnDemand.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/State/OnDemand.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Trustworthy #-} +-- | Lazy state effect +module Control.Eff.State.OnDemand where + +import Control.Eff +import Control.Eff.Extend + +import Control.Eff.Writer.Lazy +import Control.Eff.Reader.Lazy +import qualified Control.Eff.State.Lazy as S + +import Control.Monad.Base +import Control.Monad.Trans.Control + +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | State, lazy (i.e., on-demand) +-- +-- Extensible effects make it clear that where the computation is delayed +-- (which I take as an advantage) and they do maintain the degree of +-- extensibility (the delayed computation must be effect-closed, but the +-- whole computation does not have to be). +data OnDemandState s v where + Get :: OnDemandState s s + Put :: s -> OnDemandState s () + Delay :: Eff '[OnDemandState s] a -> OnDemandState s a -- Eff as a transformer + +-- | Given a continuation, respond to requests +instance Handle (OnDemandState s) r a (s -> k) where + handle step q sreq s = case sreq of + Get -> step (q ^$ s) s + Put s' -> step (q ^$ ()) s' + Delay m -> let ~(x, s') = run $ (fix (handle_relay S.withState)) m s + in step (q ^$ x) s' + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (OnDemandState s ': r)) where + type StM (Eff (OnDemandState s ': r)) a = StM (Eff r) (a,s) + liftBaseWith f = do s <- get + raise $ liftBaseWith $ \runInBase -> + f (runInBase . runState 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 #-} +get :: Member (OnDemandState s) r => Eff r s +get = send Get +{-# RULES + "get/bind" forall k. get >>= k = send Get >>= k + #-} + +-- | Write a new value of the state. +{-# NOINLINE put #-} +put :: Member (OnDemandState s) r => s -> Eff r () +put s = send (Put s) +{-# RULES + "put/bind" forall k v. put v >>= k = send (Put v) >>= k + #-} +{-# RULES + "put/semibind" forall k v. put v >> k = send (Put v) >>= (\() -> k) + #-} +-- The purpose of the rules is to expose send, which is then being +-- fuzed by the send/bind rule. The send/bind rule is very profitable! +-- These rules are essentially inlining of get/put. Somehow GHC does not +-- inline get/put, even if I put the INLINE directives and play with phases. +-- (Inlining works if I use 'inline' explicitly). + +onDemand :: Member (OnDemandState s) r => Eff '[OnDemandState s] v -> Eff r v +onDemand = send . Delay + +-- | Run a State effect +runState :: s -- ^ Initial state + -> Eff (OnDemandState s ': r) w -- ^ Effect incorporating State + -> Eff r (w,s) -- ^ Effect containing final state and a return value +runState s m = fix (handle_relay S.withState) m s + +-- | Transform the state with a function. +modify :: (Member (OnDemandState s) r) => (s -> s) -> Eff r () +modify f = get >>= put . f + +-- | Run a State effect, discarding the final state. +evalState :: s -> Eff (OnDemandState s ': r) w -> Eff r w +evalState s = fmap fst . runState s + +-- | Run a State effect and return the final state. +execState :: s -> Eff (OnDemandState s ': r) w -> Eff r s +execState s = fmap snd . runState s + +-- | A different representation of State: decomposing State into mutation +-- (Writer) and Reading. We don't define any new effects: we just handle the +-- existing ones. Thus we define a handler for two effects together. +runStateR :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s) +runStateR s (Val x) = S.withState x s +runStateR s (E q u) = case u of + U0 (Tell w) -> handle loop q (S.Put w) s + U1 (U0 Ask) -> handle loop q S.Get s + U1 (U1 u') -> relay (qComp q loop) u' s + where loop = flip runStateR + +-- | Backwards state +-- The overall state is represented with two attributes: the inherited +-- getAttr and the synthesized putAttr. +-- At the root node, putAttr becomes getAttr, tying the knot. +-- As usual, the inherited attribute is the argument (i.e., the @environment@) +-- and the synthesized is the result of the handler |go| below. +runStateBack0 :: Eff '[OnDemandState s] a -> (a,s) +runStateBack0 m = + let (x,s) = go m s in + (x,s) + where + go :: Eff '[OnDemandState s] a -> s -> (a,s) + go (Val x) s = (x,s) + go (E q u) s0 = case decomp u of + Right Get -> k s0 s0 + Right (Put s1) -> let ~(x,sp) = k () sp in (x,s1) + Right (Delay m1) -> let ~(x,s1) = go m1 s0 in k x s1 + Left _ -> error "Impossible happened: Nothing to relay!" + where + k = qComp q go + +-- | Another implementation, exploring Haskell's laziness to make putAttr +-- also technically inherited, to accumulate the sequence of +-- updates. This implementation is compatible with deep handlers, and +-- lets us play with different notions of backwardness. +runStateBack :: Eff '[OnDemandState s] a -> (a,s) +runStateBack m = + let (x,(_,sp)) = run $ go m (sp,[]) in + (x,head sp) + where + go :: Eff '[OnDemandState s] a -> ([s],[s]) -> Eff '[] (a,([s],[s])) + go = fix (handle_relay' h S.withState) + h step q Get s0@(sg, _) = step (q ^$ head sg) s0 + h step q (Put s1) (sg, sp) = step (q ^$ ()) (tail sg,sp++[s1]) + h step q (Delay m1) s0 = let ~(x,s1) = run $ go m1 s0 in step (q ^$ x) s1 + +-- ^ A different notion of backwards is realized if we change the Put handler +-- slightly. How? diff --git a/src/Control/Eff/State/Strict.hs b/src/Control/Eff/State/Strict.hs --- a/src/Control/Eff/State/Strict.hs +++ b/src/Control/Eff/State/Strict.hs @@ -1,67 +1,143 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} -- | Strict state effect +module Control.Eff.State.Strict where + +import Control.Eff +import Control.Eff.Extend + +import Control.Eff.Writer.Strict +import Control.Eff.Reader.Strict + +import Control.Monad.Base +import Control.Monad.Trans.Control + +import Data.Function (fix) + +-- ------------------------------------------------------------------------ +-- | State, strict -- --- Example: implementing `Control.Eff.Fresh` +-- Initial design: +-- The state request carries with it the state mutator function +-- We can use this request both for mutating and getting the state. +-- But see below for a better design! -- --- > runFresh' :: (Typeable i, Enum i, Num i) => Eff (Fresh i :> r) w -> i -> Eff r w --- > runFresh' m s = fst <$> runState s (loop $ admin m) --- > where --- > loop (Val x) = return x --- > loop (E u) = case decomp u of --- > Right (Fresh k) -> do --- > n <- get --- > put (n + 1) --- > loop (k n) --- > Left u' -> send (\k -> unsafeReUnion $ k <$> u') >>= loop -module Control.Eff.State.Strict( State - , get - , put - , modify - , runState - , evalState - , execState - ) where +-- > data State s v where +-- > State :: (s->s) -> State s s +-- +-- In this old design, we have assumed that the dominant operation is +-- modify. Perhaps this is not wise. Often, the reader is most nominant. +-- +-- See also below, for decomposing the State into Reader and Writer! +-- +-- The conventional design of State +data State s v where + Get :: State s s + Put :: !s -> State s () -import Data.Typeable +-- | Embed a pure value in a stateful computation, i.e., given an +-- initial state, how to interpret a pure value in a stateful +-- computation. +withState :: Monad m => a -> s -> m (a, s) +withState x s = return (x, s) -import Control.Eff +-- | Handle 'State s' requests +instance Handle (State s) r a (s -> k) where + handle step q sreq s = case sreq of + Get -> step (q ^$ s) s + Put s' -> step (q ^$ ()) s' --- | Strict state effect -data State s w = State (s -> s) (s -> w) - deriving (Typeable, Functor) +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (State s ': r)) where + type StM (Eff (State s ': r)) a = StM (Eff r) (a,s) + liftBaseWith f = do s <- get + raise $ liftBaseWith $ \runInBase -> + f (runInBase . runState 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 #-} +get :: Member (State s) r => Eff r s +get = send Get +{-# RULES + "get/bind" forall k. get >>= k = send Get >>= k + #-} + -- | Write a new value of the state. -put :: (Typeable e, Member (State e) r) => e -> Eff r () -put !s = modify $ const s +{-# NOINLINE put #-} +put :: Member (State s) r => s -> Eff r () +put !s = send (Put s) +{-# RULES + "put/bind" forall k v. put v >>= k = send (Put v) >>= k + #-} +{-# RULES + "put/semibind" forall k v. put v >> k = send (Put v) >>= (\() -> k) + #-} +-- The purpose of the rules is to expose send, which is then being +-- fuzed by the send/bind rule. The send/bind rule is very profitable! +-- These rules are essentially inlining of get/put. Somehow GHC does not +-- inline get/put, even if I put the INLINE directives and play with phases. +-- (Inlining works if I use 'inline' explicitly). --- | Return the current value of the state. -get :: (Typeable e, Member (State e) r) => Eff r e -get = send (inj . State id) +-- | Run a State effect +runState :: s -- ^ Initial state + -> Eff (State s ': r) a -- ^ Effect incorporating State + -> Eff r (a, s) -- ^ Effect containing final state and a return value +runState !s m = fix (handle_relay withState) m s -- | Transform the state with a function. -modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r () -modify f = send $ \k -> inj $ State f $ \_ -> k () - --- | Run a State effect. -runState :: Typeable s - => s -- ^ Initial state - -> Eff (State s :> r) w -- ^ Effect incorporating State - -> Eff r (s, w) -- ^ Effect containing final state and a return value -runState s0 = loop s0 . admin where - loop !s (Val x) = return (s, x) - loop !s (E u) = handleRelay u (loop s) $ - \(State t k) -> let s' = t s - in loop s' (k s') +modify :: (Member (State s) r) => (s -> s) -> Eff r () +modify f = get >>= put . f -- | Run a State effect, discarding the final state. -evalState :: Typeable s => s -> Eff (State s :> r) w -> Eff r w -evalState s = fmap snd . runState s +evalState :: s -> Eff (State s ': r) a -> Eff r a +evalState !s = fmap fst . runState s +{-# INLINE evalState #-} -- | Run a State effect and return the final state. -execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s -execState s = fmap fst . runState s +execState :: s -> Eff (State s ': r) a -> Eff r s +execState !s = fmap snd . runState s +{-# INLINE execState #-} + +-- | An encapsulated State handler, for transactional semantics +-- The global state is updated only if the transactionState finished +-- successfully +data TxState s = TxState + +-- | Embed Transactional semantics to a stateful computation. +withTxState :: Member (State s) r => a -> s -> Eff r a +withTxState x s = put s >> return x + +-- | Confer transactional semantics on a stateful computation. +transactionState :: forall s r a. Member (State s) r + => TxState s -> Eff r a -> Eff r a +transactionState _ m = do + s <- get + (fix $ respond_relay @(State s) (withTxState @s)) m s + +-- | A different representation of State: decomposing State into mutation +-- (Writer) and Reading. We don't define any new effects: we just handle the +-- existing ones. Thus we define a handler for two effects together. +runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) +runStateR !s m = loop m s + where + loop :: Eff (Writer s ': Reader s ': r) a -> s -> Eff r (a, s) + loop (Val x) = withState x + loop (E q u) = case u of + U0 (Tell w) -> handle loop q (Put w) + U1 (U0 Ask) -> handle loop q Get + U1 (U1 u') -> relay (qComp q loop) u' diff --git a/src/Control/Eff/Trace.hs b/src/Control/Eff/Trace.hs --- a/src/Control/Eff/Trace.hs +++ b/src/Control/Eff/Trace.hs @@ -1,28 +1,40 @@ {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs, DataKinds #-} +{-# LANGUAGE Safe #-} -- | A Trace effect for debugging -module Control.Eff.Trace( Trace +module Control.Eff.Trace( Trace (..) + , withTrace , trace , runTrace ) where -import Data.Typeable - import Control.Eff +import Control.Eff.Extend +import Data.Function (fix) -- | Trace effect for debugging -data Trace v = Trace String (() -> v) - deriving (Typeable, Functor) +data Trace v where + Trace :: String -> Trace () +-- | Embed a pure value in Trace context +withTrace :: a -> IO a +withTrace = return + +-- | Given a callback and request, respond to it +instance Handle Trace r a (IO k) where + handle step q (Trace s) = putStrLn s >> step (q ^$ ()) + -- | Print a string as a trace. trace :: Member Trace r => String -> Eff r () -trace x = send (inj . Trace x) +trace = send . Trace -- | Run a computation producing Traces. -runTrace :: Eff (Trace :> ()) w -> IO w -runTrace m = loop (admin m) - where - loop (Val x) = return x - loop (E u) = prjForce u $ \(Trace s k) -> putStrLn s >> loop (k ()) +-- The handler for IO request: a terminal handler +runTrace :: Eff '[Trace] w -> IO w +runTrace = fix step where + step next = eff return + (\q u -> case u of + U0 x -> handle next q x + _ -> error "Impossible: Nothing to relay!") diff --git a/src/Control/Eff/Writer/Lazy.hs b/src/Control/Eff/Writer/Lazy.hs --- a/src/Control/Eff/Writer/Lazy.hs +++ b/src/Control/Eff/Writer/Lazy.hs @@ -1,58 +1,133 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} --- | Lazy write-only state. -module Control.Eff.Writer.Lazy( Writer - , tell - , censor - , runWriter - , runFirstWriter - , runLastWriter - , runMonoidWriter - ) where +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} +-- | Lazy write-only state +module Control.Eff.Writer.Lazy ( Writer(..) + , withWriter + , tell + , censor + , runWriter + , runFirstWriter + , runLastWriter + , runListWriter + , runMonoidWriter + , execWriter + , execFirstWriter + , execLastWriter + , execListWriter + , execMonoidWriter + ) where -import Control.Applicative ((<$>), (<|>)) +import Control.Eff +import Control.Eff.Extend + +import Control.Applicative ((<|>)) + +import Control.Monad.Base +import Control.Monad.Trans.Control +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid -import Data.Typeable +#endif -import Control.Eff +import Data.Function (fix) --- | The request to remember a value of type w in the current environment -data Writer w v = Writer w v - deriving (Typeable, Functor) +-- ------------------------------------------------------------------------ +-- | The Writer monad +-- +-- In MTL's Writer monad, the told value must have a |Monoid| type. Our +-- writer has no such constraints. If we write a |Writer|-like +-- interpreter to accumulate the told values in a monoid, it will have +-- the |Monoid w| constraint then +data Writer w v where + Tell :: w -> Writer w () +-- | How to interpret a pure value in a writer context, given the +-- value for mempty. +withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b) +withWriter x empty _append = return (x, empty) +-- | Given a value to write, and a callback (which includes empty and +-- append), respond to requests. +instance Monad m => Handle (Writer w) r a (b -> (w -> b -> b) -> m (a, b)) where + handle step q (Tell w) e append = step (q ^$ ()) e append >>= + \(x, l) -> return (x, w `append` l) + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (Writer w ': r)) where + type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w]) + liftBaseWith f = raise $ liftBaseWith $ \runInBase -> + f (runInBase . runListWriter) + restoreM x = do (a, ws :: [w]) <- raise (restoreM x) + mapM_ tell ws + return a + -- | Write a new value. -tell :: (Typeable w, Member (Writer w) r) => w -> Eff r () -tell w = send $ \f -> inj $ Writer w $ f () +tell :: Member (Writer w) r => w -> Eff r () +tell w = send $ Tell w -- | Transform the state being produced. -censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a -censor f = loop . admin +censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a +censor f = fix (respond_relay' h return) where - loop (Val x) = return x - loop (E u) = interpose u loop - $ \(Writer w v) -> tell (f w) >> loop v + h :: (Eff r b -> Eff r b) -> Arrs r v b -> Writer w v -> Eff r b + h step q (Tell w) = tell (f w) >>= \x -> step (q ^$ x) --- | Handle Writer requests, using a user-provided function to accumulate values. -runWriter :: Typeable w => (w -> b -> b) -> b -> Eff (Writer w :> r) a -> Eff r (b, a) -runWriter accum b = loop . admin - where - first f (x, y) = (f x, y) - loop (Val x) = return (b, x) - loop (E u) = handleRelay u loop - $ \(Writer w v) -> first (accum w) <$> loop v +-- | Handle Writer requests, using a user-provided function to accumulate +-- values, hence no Monoid constraints. +runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) +runWriter accum b m = fix (handle_relay withWriter) m b accum +-- | Handle Writer requests, using a List to accumulate values. +runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w]) +runListWriter = runWriter (:) [] + +-- | Handle Writer requests, using a Monoid instance to accumulate values. +runMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r (a, w) +runMonoidWriter = runWriter (<>) mempty + -- | Handle Writer requests by taking the first value provided. -runFirstWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a) +runFirstWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runFirstWriter = runWriter (\w b -> Just w <|> b) Nothing -- | Handle Writer requests by overwriting previous values. -runLastWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a) +runLastWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runLastWriter = runWriter (\w b -> b <|> Just w) Nothing --- | Handle Writer requests, using a Monoid instance to accumulate values. -runMonoidWriter :: (Monoid w, Typeable w) => Eff (Writer w :> r) a -> Eff r (w, a) -runMonoidWriter = runWriter (<>) mempty +-- | Handle Writer requests, using a user-provided function to accumulate +-- values and returning the final accumulated values. +execWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r b +execWriter accum b = fmap snd . runWriter accum b +{-# INLINE execWriter #-} + +-- | Handle Writer requests, using a List to accumulate values and returning +-- the final accumulated values. +execListWriter :: Eff (Writer w ': r) a -> Eff r [w] +execListWriter = fmap snd . runListWriter +{-# INLINE execListWriter #-} + +-- | Handle Writer requests, using a Monoid instance to accumulate values and +-- returning the final accumulated values. +execMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r w +execMonoidWriter = fmap snd . runMonoidWriter +{-# INLINE execMonoidWriter #-} + +-- | Handle Writer requests by taking the first value provided and and returning +-- the final accumulated values. +execFirstWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w) +execFirstWriter = fmap snd . runFirstWriter +{-# INLINE execFirstWriter #-} + +-- | Handle Writer requests by overwriting previous values and returning +-- the final accumulated values. +execLastWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w) +execLastWriter = fmap snd . runLastWriter +{-# INLINE execLastWriter #-} diff --git a/src/Control/Eff/Writer/Strict.hs b/src/Control/Eff/Writer/Strict.hs --- a/src/Control/Eff/Writer/Strict.hs +++ b/src/Control/Eff/Writer/Strict.hs @@ -1,59 +1,133 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} --- | Strict write-only state. -module Control.Eff.Writer.Strict( Writer - , tell - , censor - , runWriter - , runFirstWriter - , runLastWriter - , runMonoidWriter - ) where +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +-- | Strict write-only state +module Control.Eff.Writer.Strict ( Writer(..) + , withWriter + , tell + , censor + , runWriter + , runFirstWriter + , runLastWriter + , runListWriter + , runMonoidWriter + , execWriter + , execFirstWriter + , execLastWriter + , execListWriter + , execMonoidWriter + ) where -import Control.Applicative ((<$>), (<|>)) +import Control.Eff +import Control.Eff.Extend + +import Control.Applicative ((<|>)) + +import Control.Monad.Base +import Control.Monad.Trans.Control +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid -import Data.Typeable +#endif -import Control.Eff +import Data.Function (fix) --- | The request to remember a value of type w in the current environment -data Writer w v = Writer !w v - deriving (Typeable, Functor) +-- ------------------------------------------------------------------------ +-- | The Writer monad +-- +-- In MTL's Writer monad, the told value must have a |Monoid| type. Our +-- writer has no such constraints. If we write a |Writer|-like +-- interpreter to accumulate the told values in a monoid, it will have +-- the |Monoid w| constraint then +data Writer w v where + Tell :: !w -> Writer w () +-- | How to interpret a pure value in a writer context, given the +-- value for mempty. +withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b) +withWriter x empty _append = return (x, empty) +-- | Given a value to write, and a callback (which includes empty and +-- append), respond to requests. +instance Monad m => Handle (Writer w) r a (b -> (w -> b -> b) -> m (a, b)) where + handle step q (Tell w) e append = step (q ^$ ()) e append >>= + \(x, l) -> return (x, w `append` l) + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (Writer w ': r)) where + type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w]) + liftBaseWith f = raise $ liftBaseWith $ \runInBase -> + f (runInBase . runListWriter) + restoreM x = do !(a, ws :: [w]) <- raise (restoreM x) + mapM_ tell ws + return a + -- | Write a new value. -tell :: (Typeable w, Member (Writer w) r) => w -> Eff r () -tell !w = send $ \f -> inj $ Writer w $ f () +tell :: Member (Writer w) r => w -> Eff r () +tell !w = send $ Tell w -- | Transform the state being produced. -censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a -censor f = loop . admin +censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a +censor f = fix (respond_relay' h return) where - loop (Val x) = return x - loop (E u) = interpose u loop - $ \(Writer w v) -> tell (f w) >> loop v + h :: (Eff r b -> Eff r b) -> Arrs r v b -> Writer w v -> Eff r b + h step q (Tell w) = tell (f w) >>= \x -> step (q ^$ x) --- | Handle Writer requests, using a user-provided function to accumulate values. -runWriter :: Typeable w => (w -> b -> b) -> b -> Eff (Writer w :> r) a -> Eff r (b, a) -runWriter accum !b = loop . admin - where - first f (x, y) = (f x, y) - loop (Val x) = return (b, x) - loop (E u) = handleRelay u loop - $ \(Writer w v) -> first (accum w) <$> loop v +-- | Handle Writer requests, using a user-provided function to accumulate +-- values, hence no Monoid constraints. +runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) +runWriter accum !b m = fix (handle_relay withWriter) m b accum +-- | Handle Writer requests, using a List to accumulate values. +runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w]) +runListWriter = runWriter (:) [] + +-- | Handle Writer requests, using a Monoid instance to accumulate values. +runMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r (a, w) +runMonoidWriter = runWriter (<>) mempty + -- | Handle Writer requests by taking the first value provided. -runFirstWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a) +runFirstWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runFirstWriter = runWriter (\w b -> Just w <|> b) Nothing -- | Handle Writer requests by overwriting previous values. -runLastWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a) +runLastWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runLastWriter = runWriter (\w b -> b <|> Just w) Nothing --- | Handle Writer requests, using a Monoid instance to accumulate values. -runMonoidWriter :: (Monoid w, Typeable w) => Eff (Writer w :> r) a -> Eff r (w, a) -runMonoidWriter = runWriter (<>) mempty +-- | Handle Writer requests, using a user-provided function to accumulate +-- values and returning the final accumulated values. +execWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r b +execWriter accum b = fmap snd . runWriter accum b +{-# INLINE execWriter #-} + +-- | Handle Writer requests, using a List to accumulate values and returning +-- the final accumulated values. +execListWriter :: Eff (Writer w ': r) a -> Eff r [w] +execListWriter = fmap snd . runListWriter +{-# INLINE execListWriter #-} + +-- | Handle Writer requests, using a Monoid instance to accumulate values and +-- returning the final accumulated values. +execMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r w +execMonoidWriter = fmap snd . runMonoidWriter +{-# INLINE execMonoidWriter #-} + +-- | Handle Writer requests by taking the first value provided and and returning +-- the final accumulated values. +execFirstWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w) +execFirstWriter = fmap snd . runFirstWriter +{-# INLINE execFirstWriter #-} + +-- | Handle Writer requests by overwriting previous values and returning +-- the final accumulated values. +execLastWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w) +execLastWriter = fmap snd . runLastWriter +{-# INLINE execLastWriter #-} diff --git a/src/Data/FTCQueue.hs b/src/Data/FTCQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/FTCQueue.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +-- | Fast type-aligned queue optimized to effectful functions @(a -> m b)@ +-- (monad continuations have this type). Constant-time append and snoc and +-- average constant-time left-edge deconstruction +module Data.FTCQueue ( + FTCQueue, + tsingleton, + (|>), -- snoc + (><), -- append + ViewL, + viewlMap, + tviewl + ) + where + +-- | Non-empty tree. Deconstruction operations make it more and more +-- left-leaning. +data FTCQueue m a b where + Leaf :: (a -> m b) -> FTCQueue m a b + Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b + + +-- Exported operations + +-- | There is no @tempty@: use (@tsingleton return@), which works just the same. +-- The names are chosen for compatibility with FastTCQueue +{-# INLINE tsingleton #-} +tsingleton :: (a -> m b) -> FTCQueue m a b +tsingleton r = Leaf r + +-- | snoc: clearly constant-time +{-# INLINE (|>) #-} +(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b +t |> r = Node t (Leaf r) + +-- | append: clearly constant-time +{-# INLINE (><) #-} +(><) :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b +t1 >< t2 = Node t1 t2 + + +-- | Left-edge deconstruction +data ViewL m a b where + TOne :: (a -> m b) -> ViewL m a b + (:|) :: (a -> m x) -> (FTCQueue m x b) -> ViewL m a b + +-- | Process the Left-edge deconstruction +{-# INLINE viewlMap #-} +viewlMap :: ViewL m a b + -> ((a -> m b) -> c) + -> (forall x. (a -> m x) -> (FTCQueue m x b) -> c) + -> c +viewlMap view tone cons = case view of + TOne k -> tone k + k :| t -> cons k t + +{-# INLINABLE tviewl #-} +tviewl :: FTCQueue m a b -> ViewL m a b +tviewl (Leaf r) = TOne r +tviewl (Node t1 t2) = go t1 t2 + where + go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b + go (Leaf r) tr = r :| tr + go (Node tl1 tl2) tr = go tl1 (Node tl2 tr) diff --git a/src/Data/OpenUnion.hs b/src/Data/OpenUnion.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenUnion.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_HADDOCK show-extensions #-} +{-# OPTIONS_GHC -Wwarn #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- Only for SetMember below, when emulating Monad Transformers +{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-} + +-- | Open unions (type-indexed co-products) for extensible effects +-- All operations are constant-time, and there is no Typeable constraint +-- +-- This is a variation of OpenUion5.hs, which relies on overlapping +-- instances instead of closed type families. Closed type families +-- have their problems: overlapping instances can resolve even +-- for unground types, but closed type families are subject to a +-- strict apartness condition. +-- +-- This implementation is very similar to OpenUnion1.hs, but without +-- the annoying Typeable constraint. We sort of emulate it: +-- +-- Our list r of open union components is a small Universe. +-- Therefore, we can use the Typeable-like evidence in that +-- universe. We hence can define +-- +-- @ +-- data Union r v where +-- Union :: t v -> TRep t r -> Union r v -- t is existential +-- @ +-- where +-- +-- @ +-- data TRep t r where +-- T0 :: TRep t (t ': r) +-- TS :: TRep t r -> TRep (any ': r) +-- @ +-- Then Member is a type class that produces TRep +-- Taken literally it doesn't seem much better than +-- OpenUinion41.hs. However, we can cheat and use the index of the +-- type t in the list r as the TRep. (We will need UnsafeCoerce then). +-- +-- The interface is the same as of other OpenUnion*.hs +module Data.OpenUnion ( Union + , inj + , prj, pattern U0' + , decomp, pattern U0, pattern U1 + , Member + , SetMember + , type(<::) + , weaken + ) where + +import Unsafe.Coerce(unsafeCoerce) + +import Data.Kind (Constraint) +import GHC.TypeLits + +-- | The data constructors of Union are not exported +-- +-- Strong Sum (Existential with the evidence) is an open union +-- t is can be a GADT and hence not necessarily a Functor. +-- Int is the index of t in the list r; that is, the index of t in the +-- universe r +data Union (r :: [ * -> * ]) v where + Union :: {-# UNPACK #-} !Int -> t v -> Union r v + +{-# INLINE prj' #-} +{-# INLINE inj' #-} +inj' :: Int -> t v -> Union r v +inj' = Union + +prj' :: Int -> Union r v -> Maybe (t v) +prj' n (Union n' x) | n == n' = Just (unsafeCoerce x) + | otherwise = Nothing + +newtype P t r = P{unP :: Int} + +-- | Typeclass that asserts that effect @t@ is contained inside the effect-list +-- @r@. +-- +-- The @FindElem@ typeclass is an implementation detail and not required for +-- using the effect list or implementing custom effects. +class (FindElem t r) => Member (t :: * -> *) r where + inj :: t v -> Union r v + prj :: Union r v -> Maybe (t v) + +-- | Pattern synonym to project the union onto the effect @t@. +pattern U0' :: Member t r => t v -> Union r v +pattern U0' h <- (prj -> Just h) where + U0' h = inj h + +-- | Explicit type-level equality condition is a dirty +-- hack to eliminate the type annotation in the trivial case, +-- such as @run (runReader () get)@. +-- +-- There is no ambiguity when finding instances for +-- @Member t (a ': b ': r)@, which the second instance is selected. +-- +-- The only case we have to concerned about is @Member t '[s]@. +-- But, in this case, values of definition is the same (if present), +-- and the first one is chosen according to GHC User Manual, since +-- the latter one is incoherent. This is the optimal choice. +instance {-# OVERLAPPING #-} t ~ s => Member t '[s] where + {-# INLINE inj #-} + {-# INLINE prj #-} + inj x = Union 0 x + prj (Union _ x) = Just (unsafeCoerce x) +-- Note that if it weren't for us wanting to use the specialized instance above +-- we wouldn't need the INCOHERENT pragma below +-- TODO: consider impact of disabling specialization +instance {-# INCOHERENT #-} (FindElem t r) => Member t r where + {-# INLINE inj #-} + {-# INLINE prj #-} + inj = inj' (unP $ (elemNo :: P t r)) + prj = prj' (unP $ (elemNo :: P t r)) + +-- | A useful operator for reducing boilerplate in signatures. +-- +-- The following lines are equivalent. +-- +-- @ +-- (Member (Exc e) r, Member (State s) r) => ... +-- [ Exc e, State s ] <:: r => ... +-- @ +type family (<::) (ms :: [* -> *]) r where + (<::) '[] r = (() :: Constraint) + (<::) (m ': ms) r = (Member m r, (<::) ms r) + +{-# INLINE [2] decomp #-} +-- | Orthogonal decomposition of the union: head and the rest. +decomp :: Union (t ': r) v -> Either (Union r v) (t v) +decomp (Union 0 v) = Right $ unsafeCoerce v +decomp (Union n v) = Left $ Union (n-1) v + +-- | Some helpful pattern synonyms. +-- U0 : the first element of the union +pattern U0 :: t v -> Union (t ': r) v +pattern U0 h <- (decomp -> Right h) where + U0 h = inj h +-- | U1 : everything excluding the first element of the union. +pattern U1 t <- (decomp -> Left t) where + U1 t = weaken t +{-# COMPLETE U0, U1 #-} + +-- Specialized version +{-# RULES "decomp/singleton" decomp = decomp0 #-} +{-# INLINE decomp0 #-} +decomp0 :: Union '[t] v -> Either (Union '[] v) (t v) +decomp0 (Union _ v) = Right $ unsafeCoerce v +-- No other case is possible + +weaken :: Union r w -> Union (any ': r) w +weaken (Union n v) = Union (n+1) v + +-- | Find the index of an element in a type-level list. +-- The element must exist +-- This is essentially a compile-time computation. +-- Using overlapping instances here is OK since this class is private to this +-- module +class FindElem (t :: * -> *) r where + elemNo :: P t r + +instance FindElem t (t ': r) where + elemNo = P 0 +instance {-# OVERLAPPABLE #-} FindElem t r => FindElem t (t' ': r) where + elemNo = P $ 1 + (unP $ (elemNo :: P t r)) +instance TypeError ('Text "Cannot unify effect types." ':$$: + 'Text "Unhandled effect: " ':<>: 'ShowType t ':$$: + 'Text "Perhaps check the type of effectful computation and the sequence of handlers for concordance?") + => FindElem t '[] where + elemNo = error "unreachable" + +-- | Using overlapping instances here is OK since this class is private to this +-- module +class EQU (a :: k) (b :: k) p | a b -> p +instance EQU a a 'True +instance {-# OVERLAPPABLE #-} (p ~ 'False) => EQU a b p + +-- | This class is used for emulating monad transformers +class Member t r => SetMember (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t +instance (EQU t1 t2 p, MemberU' p tag t1 (t2 ': r)) => SetMember tag t1 (t2 ': r) + +class Member t r => + MemberU' (f::Bool) (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t +instance MemberU' 'True tag (tag e) (tag e ': r) +instance (Member t (t' ': r), SetMember tag t r) => + MemberU' 'False tag t (t' ': r) diff --git a/src/Data/OpenUnion1.hs b/src/Data/OpenUnion1.hs deleted file mode 100644 --- a/src/Data/OpenUnion1.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Original work at . --- Open unions (type-indexed co-products) for extensible effects. --- This implementation relies on _closed_ overlapping instances --- (or closed type function overlapping soon to be added to GHC). -module Data.OpenUnion1( Union - , SetMember - , Member - , (:>) - , inj - , prj - , prjForce - , decomp - , unsafeReUnion - ) where - -import Control.Applicative ((<$>)) -import Data.Typeable - -infixl 4 - --- | infix form of `fromMaybe`. -() :: Maybe a -> a -> a -Just a _ = a -_ a = a - --- for the sake of gcast1 -newtype Id a = Id { runId :: a } - deriving Typeable - --- | Where @r@ is @t1 :> t2 ... :> tn@, @`Union` r v@ can be constructed with a --- value of type @ti v@. --- Ideally, we should be be able to add the constraint @`Member` t r@. -data Union r v = forall t. (Functor t, Typeable1 t) => Union (t v) - -instance Functor (Union r) where - {-# INLINE fmap #-} - fmap f (Union v) = Union (fmap f v) - --- | A sum data type, for composing effects -infixr 1 :> -data ((a :: * -> *) :> b) - --- | The @`Member` t r@ determines whether @t@ is anywhere in the sum type @r@. -class Member t r -instance Member t (t :> r) -instance Member t r => Member t (t' :> r) - --- | `SetMember` is similar to `Member`, but it allows types to belong to a --- \"set\". For every set, only one member can be in @r@ at any given time. --- This allows us to specify exclusivity and uniqueness among arbitrary effects: --- --- > -- Terminal effects (effects which must be run last) --- > data Terminal --- > --- > -- Make Lifts part of the Terminal effects set. --- > -- The fundep assures that there can only be one Terminal effect for any r. --- > instance Member (Lift m) r => SetMember Terminal (Lift m) r --- > --- > -- Only allow a single unique Lift effect, by making a "Lift" set. --- > instance Member (Lift m) r => SetMember Lift (Lift m) r -class Member t r => SetMember set (t :: * -> *) r | r set -> t -instance SetMember set t r => SetMember set t (t' :> r) - -{-# INLINE inj #-} --- | Construct a Union. -inj :: (Functor t, Typeable1 t, Member t r) => t v -> Union r v -inj = Union - -{-# INLINE prj #-} --- | Try extracting the contents of a Union as a given type. -prj :: (Typeable1 t, Member t r) => Union r v -> Maybe (t v) -prj (Union v) = runId <$> gcast1 (Id v) - -{-# INLINE prjForce #-} --- | Extract the contents of a Union as a given type. --- If the Union isn't of that type, a runtime error occurs. -prjForce :: (Typeable1 t, Member t r) => Union r v -> (t v -> a) -> a -prjForce u f = f <$> prj u error "prjForce with an invalid type" - -{-# INLINE decomp #-} --- | Try extracting the contents of a Union as a given type. --- If we can't, return a reduced Union that excludes the type we just checked. -decomp :: Typeable1 t => Union (t :> r) v -> Either (Union r v) (t v) -decomp u = Right <$> prj u Left (unsafeReUnion u) - -{-# INLINE unsafeReUnion #-} --- | Juggle types for a Union. Use cautiously. -unsafeReUnion :: Union r w -> Union t w -unsafeReUnion (Union v) = Union v diff --git a/test/Control/Eff/Coroutine/Test.hs b/test/Control/Eff/Coroutine/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Coroutine/Test.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module Control.Eff.Coroutine.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Coroutine +import Control.Eff.Trace +import Control.Eff.Reader.Strict +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +yieldInt :: Member (Yield Int ()) r => Int -> Eff r () +yieldInt = yield + +case_Coroutines_c1 :: Assertion +case_Coroutines_c1 = do + ((), actual) <- catchOutput c1 + assertOutput + "Coroutine: Simple coroutines using Eff" + ["1", "2", "Done"] actual + where + th1 :: Member (Yield Int ()) r => Eff r () + th1 = yieldInt 1 >> yieldInt 2 + + c1 = runTrace (loop =<< runC th1) + where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop + loop (Done) = trace ("Done") + +case_Coroutines_c2 :: Assertion +case_Coroutines_c2 = do + ((), actual1) <- catchOutput c2 + assertOutput "Coroutine: Add dynamic variables" + ["10", "10", "Done"] actual1 + ((), actual2) <- catchOutput c21 + assertOutput "Coroutine: locally changing the dynamic environment for the suspension" + ["10", "11", "Done"] actual2 + where + -- The code is essentially the same as that in transf.hs (only added + -- a type specializtion on yield). The inferred signature is different though. + -- Before it was + -- th2 :: MonadReader Int m => CoT Int m () + -- Now it is more general: + th2 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r () + th2 = ask >>= yieldInt >> (ask >>= yieldInt) + + -- Code is essentially the same as in transf.hs; no liftIO though + c2 = runTrace $ runReader (10::Int) (loop =<< runC th2) + where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop + loop Done = trace "Done" + + -- locally changing the dynamic environment for the suspension + c21 = runTrace $ runReader (10::Int) (loop =<< runC th2) + where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop + loop Done = trace "Done" + +case_Coroutines_c3 :: Assertion +case_Coroutines_c3 = do + ((), actual1) <- catchOutput c3 + assertOutput "Coroutine: two sorts of local rebinding" + ["10", "10", "20", "20", "Done"] actual1 + ((), actual2) <- catchOutput c31 + let expected2 = ["10", "11", "21", "21", "Done"] + assertOutput "Coroutine: locally changing the dynamic environment for the suspension" + expected2 actual2 + ((), actual3) <- catchOutput c4 + assertOutput "Coroutine: abstracting the client computation" + expected2 actual3 + where + th3 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r () + th3 = ay >> ay >> local (+(10::Int)) (ay >> ay) + where ay = ask >>= yieldInt + + c3 = runTrace $ runReader (10::Int) (loop =<< runC th3) + where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop + loop Done = trace "Done" + + -- The desired result: the coroutine shares the dynamic environment with its + -- parent; however, when the environment is locally rebound, it becomes + -- private to coroutine. + c31 = runTrace $ runReader (10::Int) (loop =<< runC th3) + where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop + loop Done = trace "Done" + + -- We now make explicit that the client computation, run by th4, + -- is abstract. We abstract it out of th4 + c4 = runTrace $ runReader (10::Int) (loop =<< runC (th4 client)) + where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop + loop Done = trace "Done" + + -- cl, client, ay are monomorphic bindings + th4 cl = cl >> local (+(10::Int)) cl + client = ay >> ay + ay = ask >>= yieldInt + +case_Corountines_c5 :: Assertion +case_Corountines_c5 = do + ((), actual) <- catchOutput c5 + let expected = ["10" + ,"11" + ,"12" + ,"18" + ,"18" + ,"18" + ,"29" + ,"29" + ,"29" + ,"29" + ,"29" + ,"29" + ,"Done" + ] + assertOutput "Corountine: Even more dynamic example" + expected actual + where + c5 = runTrace $ runReader (10::Int) (loop =<< runC (th client)) + where loop (Y k x) = trace (show (x::Int)) >> local (\_y->x+1) (k ()) >>= loop + loop Done = trace "Done" + + -- cl, client, ay are monomorphic bindings + client = ay >> ay >> ay + ay = ask >>= yieldInt + + -- There is no polymorphic recursion here + th cl = do + cl + v <- ask + (if v > (20::Int) then id else local (+(5::Int))) cl + if v > (20::Int) then return () else local (+(10::Int)) (th cl) + +case_Coroutines_c7 :: Assertion +case_Coroutines_c7 = do + ((), actual) <- catchOutput c7 + let expected = ["1010" + ,"1021" + ,"1032" + ,"1048" + ,"1064" + ,"1080" + ,"1101" + ,"1122" + ,"1143" + ,"1169" + ,"1195" + ,"1221" + ,"1252" + ,"1283" + ,"1314" + ,"1345" + ,"1376" + ,"1407" + ,"Done" + ] + assertOutput "Coroutine: And even more dynamic example" + expected actual + where + c7 = runTrace $ + runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client))) + where loop (Y k x) = trace (show (x::Int)) >> + local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop + loop Done = trace "Done" + + -- cl, client, ay are monomorphic bindings + client = ay >> ay >> ay + ay = ask >>= \x -> ask >>= + \y -> yieldInt (x + round (y::Double)) + + -- There is no polymorphic recursion here + th cl = do + cl + v <- ask + (if v > (20::Int) then id else local (+(5::Int))) cl + if v > (20::Int) then return () else local (+(10::Int)) (th cl) + +case_Coroutines_c7' :: Assertion +case_Coroutines_c7' = do + ((), actual) <- catchOutput c7' + let expected = ["1010" + ,"1021" + ,"1032" + ,"1048" + ,"1048" + ,"1048" + ,"1069" + ,"1090" + ,"1111" + ,"1137" + ,"1137" + ,"1137" + ,"1168" + ,"1199" + ,"1230" + ,"1261" + ,"1292" + ,"1323" + ,"Done" + ] + assertOutput "Coroutine: And even more dynamic example" + expected actual + where + c7' = runTrace $ + runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client))) + where loop (Y k x) = trace (show (x::Int)) >> + local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop + loop Done = trace "Done" + + -- cl, client, ay are monomorphic bindings + client = ay >> ay >> ay + ay = ask >>= \x -> ask >>= + \y -> yieldInt (x + round (y::Double)) + + -- There is no polymorphic recursion here + th cl = do + cl + v <- ask + (if v > (20::Int) then id else local (+(5::Double))) cl + if v > (20::Int) then return () else local (+(10::Int)) (th cl) diff --git a/test/Control/Eff/Example/Test.hs b/test/Control/Eff/Example/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Example/Test.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleContexts, AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Eff.Example.Test (testGroups, ex2) where + +import Test.HUnit hiding (State) +import Test.QuickCheck +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +import Control.Eff +import Control.Eff.Example +import Control.Eff.Exception +import Control.Eff.Reader.Lazy +import Control.Eff.Writer.Lazy +import Control.Eff.State.Lazy +import Utils + +testGroups = [ $(testGroupGenerator) ] + +-- The type is inferred +-- ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int +ex2 m = do + v <- m + if v > 5 then throwError (TooBig v) + else return v + +case_Exception1_ex2r :: Assertion +case_Exception1_ex2r = (Right 5) @=? (run ex2r) + where + ex2r = runReader (5::Int) (runErrBig (ex2 ask)) + +case_Exception1_ex2r1 :: Assertion +case_Exception1_ex2r1 = (Left (TooBig 7)) @=? (run ex2r1) + where + ex2r1 = runReader (7::Int) (runErrBig (ex2 ask)) + +-- Different order of handlers (layers) +case_Exception1_ex2r2 :: Assertion +case_Exception1_ex2r2 = (Left (TooBig 7)) @=? (run ex2r2) + where + ex2r2 = runErrBig (runReader (7::Int) (ex2 ask)) + +case_multiple_eff_sum2 :: Assertion +case_multiple_eff_sum2 = + assertEqual "Int : Float" 33 intThenFloat + >> assertEqual "Float : Int" intThenFloat floatThenInt + where + intThenFloat = run $ runReader (20::Float) (runReader (10::Int) sum2) + floatThenInt = run $ runReader (10::Int) (runReader (20::Float) sum2) + +prop_Documentation_example :: [Integer] -> Property +prop_Documentation_example l = let + ((), total1) = run $ runState 0 (sumAll l) + ((), last1) = run $ runLastWriter $ writeAll l + (((), last2), total2) = run $ runState 0 (runLastWriter (writeAndAdd l)) + (((), total3), last3) = run $ runLastWriter $ runState 0 (writeAndAdd l) + in + allEqual [safeLast l, last1, last2, last3] + .&&. allEqual [sum l, total1, total2, total3] diff --git a/test/Control/Eff/Exception/Test.hs b/test/Control/Eff/Exception/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Exception/Test.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +module Control.Eff.Exception.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Exception +import Control.Eff.Writer.Strict +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +-- The type is inferred +-- et1 :: Eff r Int +et1 = return 1 `add` return 2 + +case_Exception1_et1 :: Assertion +case_Exception1_et1 = 3 @=? (run et1) + +-- The type is inferred +-- et2 :: Member (Exc Int) r => Eff r Int +et2 = return 1 `add` throwError (2::Int) + +-- The following won't type: unhandled exception! +-- ex2rw = run et2 +{- + Could not deduce (Data.OpenUnion.FindElem (Exc Int) '[]) + arising from a use of `et2' +-} + +case_Exception1_et21 :: Assertion +case_Exception1_et21 = (Left (2::Int)) @=? + (run et21) + where + -- The inferred type shows that ex21 is now pure + -- et21 :: Eff r (Either Int Int) + + et21 = runError et2 + +-- Implementing the operator <|> from Alternative: +-- a <|> b does +-- -- tries a, and if succeeds, returns its result +-- -- otherwise, tries b, and if succeeds, returns its result +-- -- otherwise, throws mappend of exceptions of a and b + +-- We use SetMember in the signature rather than Member to +-- ensure that the computation throws only one type of exceptions. +-- Otherwise, this construction is not very useful. +alttry :: forall e r a. (Monoid e, SetMember Exc (Exc e) r) => + Eff r a -> Eff r a -> Eff r a +alttry ma mb = + catchError ma $ \ea -> + catchError mb $ \eb -> throwError (mappend (ea::e) eb) + +case_Exception1_alttry :: Assertion +case_Exception1_alttry = + [Right 10,Right 10,Right 10,Left "bummer1bummer2"] @=? + [ + run . runError $ + (return 1 `add` throwError "bummer1") `alttry` + (return 10), + run . runError $ + (return 10) `alttry` + (return 1 `add` throwError "bummer2"), + run . runError $ + (return 10) `alttry` return 20, + run . runError $ + (return 1 `add` throwError "bummer1") `alttry` + (return 1 `add` throwError "bummer2") + ] + +case_Failure1_Effect :: Assertion +case_Failure1_Effect = + let go :: Eff (Exc () ': Writer Int ': '[]) Int + -> Int + go = snd . run . runWriter (+) 0 . ignoreFail + ret = go $ do + tell (1 :: Int) + tell (2 :: Int) + tell (3 :: Int) + () <- die + 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" diff --git a/test/Control/Eff/Fresh/Test.hs b/test/Control/Eff/Fresh/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Fresh/Test.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Fresh.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Fresh +import Control.Eff.Trace +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Fresh_tfresh' :: Assertion +case_Fresh_tfresh' = do + ((), actual) <- catchOutput tfresh' + assertOutput "Fresh: test" + ["Fresh 0", "Fresh 1"] actual + where + tfresh' = runTrace $ runFresh' 0 $ do + n <- fresh + trace $ "Fresh " ++ show n + n <- fresh + trace $ "Fresh " ++ show n + +case_Fresh_monadBaseControl :: Assertion +case_Fresh_monadBaseControl = runLift (runFresh' i (doThing $ fresh >> fresh)) @=? Just (i + 1) + where + i = 0 diff --git a/test/Control/Eff/Logic/NDet/Bench.hs b/test/Control/Eff/Logic/NDet/Bench.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Logic/NDet/Bench.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} + +-- A benchmark of shift/reset: Filinski's representing non-determinism monads +-- +-- The benchmark is taken from Sec 6.1 of +-- Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct +-- Implementation of Shift and Reset, ICFP'02, pp. 271-282. +-- http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf +-- This code is a straightforward translation of bench_nondet.ml +-- +-- This is a micro-benchmark: it is very non-determinism-intensive. It is +-- *not* representative: the benchmark does nothing else but +-- concatenates lists. The List monad does this directly; whereas +-- continuation monads do the concatenation with more overhead (e.g., +-- building the closures representing continuations). Therefore, +-- the List monad here outperforms all other implementations of +-- non-determinism. +-- It should be stressed that the delimited control is optimized +-- for the case where control operations are infrequent, so we pay +-- as we go. The use of the delimited control operators is more +-- expensive, but the code that does not use delimited control does not +-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that +-- does not use non-determinism, so the overhead of delimited control +-- is very noticeable. That is why this benchmark is good at estimating +-- the overhead of different implementations of delimited control. + +-- To compile this code +-- ghc -O2 -rtsopts -main-is Bench_nondet.main_list5 Bench_nondet.hs +-- To run this code +-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet + +module Control.Eff.Logic.NDet.Bench where + +import Control.Eff +import qualified Control.Eff.Logic.NDet as E + +import Data.List (sort) +-- import Control.Monad.Identity +-- import Control.Monad (liftM2) +import Control.Monad (MonadPlus(..), msum) +import Control.Applicative +-- import System.CPUTime + +-- Small language with non-determinism: just like the one in our DSL-WC paper + +int :: MonadPlus repr => Int -> repr Int +int x = return x + +add :: MonadPlus repr => repr Int -> repr Int -> repr Int +-- add xs ys = liftM2 (+) xs ys +add xs ys = do {x <- xs; y <- ys; return $! x+y } + +lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b) +lam f = return $ f . return + +app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b) +app xs ys = do {x <- xs; y <- ys; x y} + +amb :: MonadPlus repr => [repr Int] -> repr Int +amb = msum + +-- Benchmark cases + +test_ww :: MonadPlus repr => repr Int +test_ww = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32] + +ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13, + 12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15, + 14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15, + 16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, + 14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12, + 11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36, + 38, 39, 38, 35, 42, 44, 45, 44, 41] + +-- Real benchmark cases + +test_www :: MonadPlus repr => repr Int +test_www = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]) + +test_wwww :: MonadPlus repr => repr Int +test_wwww = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])) + +test_w5 :: MonadPlus repr => repr Int +test_w5 = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` + (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))) + + +-- Different implementations of our language (MonadPlus) + +-- The List monad: Non-determinism monad as a list of successes + +run_list :: [Int] -> [Int] +run_list = id + +testl1 = (==) [101, 201, 102, 202] . run_list $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testl2 = ww_answer == sort (run_list test_ww) + + +-- CPS-monad, implemented by hand; it must be quite efficient therefore +-- It is a monad, not a transformer. It cannot do any other effects beside +-- the non-determinism. +newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]} + +instance Functor CPS where + fmap f fa = CPS $ \k -> unCPS fa (k . f) +instance Applicative CPS where + pure x = CPS $ \k -> k x + mf <*> fa = CPS $ \k -> unCPS mf (\f -> unCPS fa (k . f)) +instance Monad CPS where + return x = CPS $ \k -> k x + m >>= f = CPS $ \k -> unCPS m (\a -> unCPS (f a) k) + +instance Alternative CPS where + empty = mzero + (<|>) = mplus +instance MonadPlus CPS where + mzero = CPS $ \_ -> [] + mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k + +run_cps :: CPS Int -> [Int] +run_cps m = unCPS m (\x -> [x]) + + +testc1 = (==) [101, 201, 102, 202] . run_cps $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testc2 = ww_answer == sort (run_cps test_ww) + +-- ExtEff implementation +-- Eff is already an instance of MonadPlus. Thus we only need to +-- define the run instance + +-- run_eff :: Eff '[E.Choose] Int -> [Int] +-- run_eff = run . E.makeChoice + +-- More direct interpreter +-- makeChoiceA :: Eff (E.NDet ': r) a -> Eff r [a] +-- makeChoiceA = handle_relay (\x -> x `seq` return [x] ) $ \m k -> case m of +-- E.MZero -> return [] +-- E.MPlus -> liftM2 (++) (k True) (k False) + +run_eff :: Eff '[E.NDet] Int -> [Int] +run_eff = run . E.makeChoiceA + +teste2 = ww_answer == sort (run_eff test_ww) + + +data Count a = Count (Maybe a) !Int +instance Functor Count where + fmap f (Count (Just x) n) = Count (Just (f x)) n + fmap _ _ = Count Nothing 0 + +instance Applicative Count where + pure x = Count (Just x) 1 + Count (Just f) nf <*> Count (Just x) nx = Count (Just (f x)) (nf + nx) + _ <*> _ = Count Nothing 0 + +instance Alternative Count where + empty = Count Nothing 0 + Count m1@Just{} n1 <|> Count _ n2 = Count m1 (n1+n2) + _ <|> m2 = m2 + +run_effc :: Eff '[E.NDet] Int -> Int +run_effc m = let Count _ n = run . E.makeChoiceA $ m in n + + +teste12 = length ww_answer == run_effc test_ww + +{- +-- CCEx monad +-- Not a very optimal implementation of mplus (a tree would be better) +-- But is suffices as a benchmark of different implementations of CC +instance Monad m => MonadPlus (CC (PS [Int]) m) where + mzero = abortP ps (return []) + mplus m1 m2 = takeSubCont ps (\k -> + liftM2 (++) + (pushPrompt ps (pushSubCont k m1)) + (pushPrompt ps (pushSubCont k m2))) + +run_dir :: CC (PS [Int]) Identity Int -> [Int] +run_dir m = runIdentity . runCC $ + pushPrompt ps (m >>= return . (:[])) + + +testd1 = (==) [101, 201, 102, 202] . run_dir $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testd2 = ww_answer == sort (run_dir test_ww) + +-} + + +-- Benchmarks themselves + +main_list3 = print $ 2400 == (length . run_list $ test_www) +main_list4 = print $ 48000 == (length . run_list $ test_wwww) +main_list5 = print $ 960000 == (length . run_list $ test_w5) + +main_cps3 = print $ 2400 == (length . run_cps $ test_www) +main_cps4 = print $ 48000 == (length . run_cps $ test_wwww) +main_cps5 = print $ 960000 == (length . run_cps $ test_w5) + +-- We expect the direct implementation to be slower since CC is the transformer, +-- whereas CPS is not. The latter is hand-written for a specific answer-type. +main_eff3 = print $ 2400 == (length . run_eff $ test_www) +main_eff4 = print $ 48000 == (length . run_eff $ test_wwww) +main_eff5 = print $ 960000 == (length . run_eff $ test_w5) + +main_eff5c = print $ 960000 == (run_effc $ test_w5) + +-- To clarify the effect of building a list +main_eff5m = print $ ((run . E.makeChoiceA $ test_w5) :: Maybe Int) + +{- +-- Instantiate CC to the IO as the base monad, attempting to quantify the +-- effect of the Identity transformer +main_dir5io = do + l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[])) + print $ length l == 960000 +-} + +-- ------------------------------------------------------------------------ +-- Old results, from 2010 + +{- Median of 5 runs + +main_list5 +<> + 0.30 real 0.30 user 0.00 sys + +main_cps5 +<> + 0.60 real 0.58 user 0.01 sys + +main_dir5 (CCExc implementation) +<> + 4.48 real 4.22 user 0.24 sys + +main_dir5io (CCExc implementation) +<> + 5.45 real 5.18 user 0.21 sys + + +main_dir5 (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.70 real 4.44 user 0.23 sys + +main_dir5io (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.72 real 4.44 user 0.23 sys + +main_ref5io (without pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 68.94 real 67.51 user 1.03 sys + + +main_ref5io (with pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 20.50 real 19.92 user 0.46 sys + +-} + +-- ------------------------------------------------------------------------ +-- Newer Benchmarks, July 2015 + +{- +main_list5 +True +<> + +main_cps5 +True +<> + +-- using makeChoiceA (setting f as an Alternative) +main_eff5 +True +<> + +With strict add: +True +<> +1.32user 0.08system 0:01.40elapsed 99%CPU (0avgtext+0avgdata 819408maxresident)k +0inputs+0outputs (0major+51485minor)pagefaults 0swaps + +It looks like a huge memory leak. Perhaps the list is fully realized? + + +Using the counting Alternative Count +True +<> + +Using Maybe +Just 32 +<> +0.67user 0.05system 0:00.72elapsed 100%CPU (0avgtext+0avgdata 620752maxresident)k +0inputs+0outputs (0major+38937minor)pagefaults 0swaps + +-- using Maybe, but with the better makeChoice +Just 32 +<> +0.63user 0.04system 0:00.68elapsed 100%CPU (0avgtext+0avgdata 570720maxresident)k +0inputs+0outputs (0major+35760minor)pagefaults 0swaps + +Better makeChoiceA, full list +True +<> +0.42user 0.02system 0:00.44elapsed 100%CPU (0avgtext+0avgdata 244064maxresident)k +0inputs+0outputs (0major+15391minor)pagefaults 0swaps + +-} diff --git a/test/Control/Eff/Logic/NDet/Test.hs b/test/Control/Eff/Logic/NDet/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Logic/NDet/Test.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Logic.NDet.Test (testGroups, gen_testCA, gen_ifte_test) +where + +import Test.HUnit hiding (State) +import Control.Applicative +import Control.Eff +import Control.Eff.Example +import Control.Eff.Example.Test (ex2) +import Control.Eff.Exception +import Control.Eff.Logic.NDet +import Control.Eff.Writer.Strict +import Control.Monad (msum, guard, mzero, mplus) +import Control.Eff.Logic.Test +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +gen_testCA :: (Integral a) => a -> Eff (NDet ': r) a +gen_testCA x = do + i <- msum . fmap return $ [1..x] + guard (i `mod` 2 == 0) + return i + +case_NDet_testCA :: Assertion +case_NDet_testCA = [2, 4..10] @=? (run $ makeChoiceA (gen_testCA 10)) + +case_Choose1_exc11 :: Assertion +case_Choose1_exc11 = [2,3] @=? (run exc11) + where + exc11 = makeChoice exc1 + exc1 = return 1 `add` choose [1,2] + +case_Choose_exRec :: Assertion +case_Choose_exRec = + let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1])) + exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1])) + exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1])) + exRec_4 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,11,1])) + in + assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1 + >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2 + >> assertEqual "Choose: error recovery: exRec_3" expected3 exRec_3 + >> assertEqual "Choose: error recovery: exRec_4" expected4 exRec_4 + where + expected1 = Right [5,7,1] + expected2 = [Right 5,Right 7,Right 1] + expected3 = Left (TooBig 11) + expected4 = [Right 5,Right 7,Left (TooBig 11),Right 1] + -- Errror recovery part + -- The code is the same as in transf1.hs. The inferred signatures differ + -- Was: exRec :: MonadError TooBig m => m Int -> m Int + -- exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int + exRec m = catchError m handler + where handler (TooBig n) | n <= 7 = return n + handler e = throwError e + +case_Choose_ex2 :: Assertion +case_Choose_ex2 = + let ex2_1 = run . makeChoice . runErrBig $ ex2 (choose [5,7,1]) + ex2_2 = run . runErrBig . makeChoice $ ex2 (choose [5,7,1]) + in + assertEqual "Choose: Combining exceptions and non-determinism: ex2_1" + expected1 ex2_1 + >> assertEqual "Choose: Combining exceptions and non-determinism: ex2_2" + expected2 ex2_2 + where + expected1 = [Right 5,Left (TooBig 7),Right 1] + expected2 = Left (TooBig 7) + +gen_ifte_test x = do + n <- gen x + ifte (do + d <- gen x + guard $ d < n && n `mod` d == 0 + -- _ <- trace ("d: " ++ show d) (return ()) + ) + (\_ -> mzero) + (return n) + where gen x = msum . fmap return $ [2..x] + + +case_NDet_ifte :: Assertion +case_NDet_ifte = + let primes = ifte_test_run + in + assertEqual "NDet: test ifte using primes" + [2,3,5,7,11,13,17,19,23,29] primes + where + ifte_test_run :: [Int] + ifte_test_run = run . makeChoiceA $ (gen_ifte_test 30) + + +-- called reflect in the LogicT paper +case_NDet_reflect :: Assertion +case_NDet_reflect = + let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit + tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= reflect) + tsplitr20 = run $ makeChoiceA $ runListWriter tsplit + tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= reflect) + in + assertEqual "tsplitr10" expected1 tsplitr10 + >> assertEqual "tsplitr11" expected1 tsplitr11 + >> assertEqual "tsplitr20" expected2 tsplitr20 + >> assertEqual "tsplitr21" expected21 tsplitr21 + where + expected1 = ([1, 2],["begin", "end"]) + expected2 = [(1, ["begin"]), (2, ["end"])] + expected21 = [(1, ["begin"]), (2, ["begin", "end"])] + + tsplit = + (tell "begin" >> return 1) `mplus` + (tell "end" >> return 2) + +case_NDet_monadBaseControl :: Assertion +case_NDet_monadBaseControl = runLift (makeChoiceA $ doThing (return 1 <|> return 2)) @=? Just [1,2] + +case_Choose_monadBaseControl :: Assertion +case_Choose_monadBaseControl = runLift (makeChoice $ doThing $ choose [1,2,3]) @=? Just [1,2,3] + +case_NDet_cut :: Assertion +case_NDet_cut = testCut (run . makeChoice) + +case_NDet_monadplus :: Assertion +case_NDet_monadplus = + let evalnw = run . (runListWriter @Int) . makeChoice + evalwn = run . makeChoice . (runListWriter @Int) + casesnw = [ + -- mplus laws + ("0 | NDet, Writer", evalnw t0, nw0) + , ("zm0 = 0 | NDet, Writer", evalnw tzm0, nw0) + , ("0m1 | NDet, Writer", evalnw t0m1, nw0m1) + , ("zm0mzm1 = 0m1 | NDet, Writer", evalnw tzm0mzm1, nw0m1) + -- mzero laws + , ("z | NDet, Writer", evalnw tz, nwz) + , ("z0 = z | NDet, Writer", evalnw tz0, nwz) + , ("0z /= z | NDet, Writer", evalnw t0z, nw0z) + , ("z0m1 = 1 | NDet, Writer", evalnw tz0m1, nw1) + , ("0zm1 /= 1 | NDet, Writer", evalnw t0zm1, nw0zm1) + ] + caseswn = [ + -- mplus laws + ("0 | Writer, NDet", evalwn t0, wn0) + , ("zm0 = 0 | Writer, NDet", evalwn tzm0, wn0) + , ("0m1 | Writer, NDet", evalwn t0m1, wn0m1) + , ("zm0mzm1 = 0m1 | Writer, NDet", evalwn tzm0mzm1, wn0m1) + -- mzero laws + , ("z | Writer, NDet", evalwn tz, wnz) + , ("z0 = z | Writer, NDet", evalwn tz0, wnz) + , ("0z = z | Writer, NDet", evalwn t0z, wnz) + , ("z0m1 = 1 | Writer, NDet", evalwn tz0m1, wn1) + , ("0zm1 = 1 | Writer, NDet", evalwn t0zm1, wn1) + ] + in runAsserts assertEqual casesnw + >> runAsserts assertEqual caseswn + where + nwz = ([]::[Int],[]) + wnz = [] ::[(Int, [Int])] + nw0z = ([]::[Int],[0]) + nw0 = ([0],[0]) + nw1 = ([1],[1]) + nw0zm1 = ([1],[0,1]) + wn0 = [(0,[0])] + wn1 = [(1,[1])] + + nw0m1 = ([0::Int,1],[0,1]) + wn0m1 = [(0,[0]), (1,[1])] + + t0 = wr @Int 0 + t1 = wr @Int 1 + + tz = mzero + tz0 = tz >> t0 + t0z = t0 >> tz + tz0m1 = tz0 `mplus` t1 + t0zm1 = t0z `mplus` t1 + + t0m1 = t0 `mplus` t1 + tzm0 = tz `mplus` t0 + tzm1 = tz `mplus` t1 + tzm0mzm1 = tzm0 `mplus` tzm1 + + wr :: forall a r. [Writer a, NDet] <:: r => a -> Eff r a + wr i = tell i >> return i diff --git a/test/Control/Eff/Logic/Test.hs b/test/Control/Eff/Logic/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Logic/Test.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Logic.Test where + +import Test.HUnit hiding (State) +import Control.Eff.Logic.Core +import Control.Monad + +-- the inferred signature of testCut is insightful +testCut runChoice = + let cases = [tcut1, tcut2, tcut3, tcut4, tcut5, tcut6, tcut7, tcut8 + , tcut9] + runCall = runChoice . call + in + forM_ cases $ \(test, result) -> + assertEqual "Cut: tcut" result (runCall test) + where + -- signature is inferred + -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int + tc1 = (return (1::Int) `mplus` return 2) `mplus` + ((cutfalse `mplus` return 4) `mplus` + return 5) + rc1 = [1,2] + tcut1 = (tc1, rc1) + -- Here we see nested call. It poses no problems... + tc2 = return (1::Int) `mplus` + call (return 2 `mplus` (cutfalse `mplus` return 3) `mplus` + return 4) + `mplus` return 5 + rc2 = [1,2,5] + tcut2 = (tc2, rc2) + tcut3 = ((call tc1 `mplus` call (tc2 `mplus` cutfalse)) + , rc1 ++ rc2) + tcut4 = ((call tc1 `mplus` (tc2 `mplus` cutfalse)) + , rc1 ++ rc2) + tcut5 = ((call tc1 `mplus` (cutfalse `mplus` tc2)) + , rc1) + tcut6 = ((call tc1 `mplus` call (cutfalse `mplus` tc2)) + , rc1) + tcut7 = ((call tc1 `mplus` (cutfalse `mplus` tc2) `mplus` tc2) + , rc1) + tcut8 = ((call tc1 `mplus` call (cutfalse `mplus` tc2) `mplus` tc2) + , rc1 ++ rc2) + incrOrDecr = \x -> (return $! x + 1) + `mplus` cutfalse + `mplus` (return $! x - 1) + tc9 = tc1 >>= incrOrDecr + rc9 = [2] + tcut9 = (tc9, rc9) + -- tcut10 = ((return rc1 >>= incrOrDecr) + -- , rc9) diff --git a/test/Control/Eff/Operational/Test.hs b/test/Control/Eff/Operational/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Operational/Test.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DataKinds, TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Operational.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Operational +import Control.Eff.Operational.Example as Eg +import Control.Eff.State.Lazy +import Control.Eff.Writer.Lazy + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Operational_Monad :: Assertion +case_Operational_Monad = + let comp :: (Member (State [String]) r + , Member (Writer String) r) + => Eff r () + comp = runProgram Eg.adventPure Eg.prog + go = snd . run . runMonoidWriter $ evalState ["foo", "bar"] comp + in + assertEqual + "Evaluating Operational Monad example" + (unlines ["getting input...", + "ok", + "the input is foo"]) go diff --git a/test/Control/Eff/Reader/Lazy/Test.hs b/test/Control/Eff/Reader/Lazy/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Reader/Lazy/Test.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Control.Eff.Reader.Lazy.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Reader.Lazy +import Control.Monad +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +t1 = ask `add` return (1::Int) + +case_Lazy1_Reader_t1 :: Assertion +case_Lazy1_Reader_t1 = let + t1' = do v <- ask; return (v + 1 :: Int) + t1r = runReader (10::Int) t1 + in + -- 'run t1' should result in type-error + 11 @=? (run t1r) + +t2 = do + v1 <- ask + v2 <- ask + return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float)) + + +case_Lazy1_Reader_t2 :: Assertion +case_Lazy1_Reader_t2 = let + t2r = runReader (10::Int) t2 + t2rr = runReader (20::Float) . runReader (10::Int) $ t2 + in + 33.0 @=? (run t2rr) + +-- The opposite order of layers +{- If we mess up, we get an error +t2rrr1' = run $ runReader (runReader t2 (20::Float)) (10::Float) + No instance for (Member (Reader Int) []) + arising from a use of `t2' +-} +case_Lazy1_Reader_t2' :: Assertion +case_Lazy1_Reader_t2' = 33.0 @=? + (run $ runReader (10 :: Int) . runReader (20 :: Float) $ t2) + + +case_Lazy1_Reader_t3 :: Assertion +case_Lazy1_Reader_t3 = let + t3 = t1 `add` local (+ (10::Int)) t1 + in + 212 @=? (run $ runReader (100::Int) t3) + +-- The following example demonstrates true interleaving of Reader Int +-- and Reader Float layers +{- +t4 + :: (Member (Reader Int) r, Member (Reader Float) r) => + () -> Eff r Float +-} +t4 = liftM2 (+) (local (+ (10::Int)) t2) + (local (+ (30::Float)) t2) + +case_Lazy1_Reader_t4 :: Assertion +case_Lazy1_Reader_t4 = 106.0 @=? + (run $ runReader (10::Int) . runReader (20::Float) $ t4) + +-- The opposite order of layers gives the same result +case_Lazy1_Reader_t4' :: Assertion +case_Lazy1_Reader_t4' = 106.0 @=? + (run $ runReader (10::Int) . runReader (20::Float) $ t4) + +-- Map an effectful function +case_Lazy1_Reader_tmap :: Assertion +case_Lazy1_Reader_tmap = let + tmap = mapM f [1..5] + in + ([11,12,13,14,15] :: [Int]) @=? + (run $ runReader (10::Int) tmap) + where + f x = ask `add` return x + +case_Lazy1_Reader_runReader :: Assertion +case_Lazy1_Reader_runReader = let + e = run $ runReader (undefined :: ()) voidReader + in + assertNoUndefined (e :: ()) + where + voidReader = do + _ <- (ask :: Eff '[Reader ()] ()) + return () + +case_Lazy1_Reader_monadBaseControl :: Assertion +case_Lazy1_Reader_monadBaseControl = + runLift (runReader i act) @=? (Just i) + where + act = doThing ask + i = 10 :: Int diff --git a/test/Control/Eff/Reader/Strict/Test.hs b/test/Control/Eff/Reader/Strict/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Reader/Strict/Test.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Reader.Strict.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Reader.Strict +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Strict1_Reader_runReader :: Assertion +case_Strict1_Reader_runReader = let + e = run $ runReader (undefined :: ()) voidReader + in + assertUndefined (e :: ()) + where + voidReader = do + _ <- (ask :: Eff '[Reader ()] ()) + return () + +case_Strict1_Reader_monadBaseControl :: Assertion +case_Strict1_Reader_monadBaseControl = + runLift (runReader i act) @=? (Just i) + where + act = doThing ask + i = 10 :: Int diff --git a/test/Control/Eff/State/Lazy/Test.hs b/test/Control/Eff/State/Lazy/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/State/Lazy/Test.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.State.Lazy.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.State.Lazy +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Lazy1_State_runState :: Assertion +case_Lazy1_State_runState = let + (r, ()) = run + $ runState undefined + $ getVoid + >> putVoid undefined + >> putVoid () + in + assertNoUndefined r + where + getVoid :: Eff '[State ()] () + getVoid = get + + putVoid :: () -> Eff '[State ()] () + putVoid = put + +case_Lazy1_State_monadBaseControl :: Assertion +case_Lazy1_State_monadBaseControl = runLift (runState i (doThing $ modify f)) @=? Just ((), i + 1) + where + i = 0 :: Int + f = succ :: Int -> Int diff --git a/test/Control/Eff/State/OnDemand/Test.hs b/test/Control/Eff/State/OnDemand/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/State/OnDemand/Test.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module Control.Eff.State.OnDemand.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Exception +import Control.Eff.State.OnDemand +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_LazierState_ex1 :: Assertion +case_LazierState_ex1 = + let actual = run $ runState 0 lex1 + in + assertEqual "OnDemandState: ex1" + ((), 1::Int) actual + where + lex1 = do + onDemand lex1 + put (1::Int) + +case_LazierState_ex3 :: Assertion +case_LazierState_ex3 = + let (x,s) = run $ runState (undefined::[Int]) lex3 + in assertEqual "OnDemandState: ex3" + ((),[1,1,1,1,1]) (x,take 5 s) + where + lex3 = do + onDemand lex3 + modify ((1::Int):) + +-- a bit more interesting +case_LazierState_ex4 = + let (x,s) = run $ runState [] lex4 + in assertEqual "OnDemandState: ex4" + expect (take 7 $ x,take 5 $ s) + where + expect = ([3,2,3,2,3,2,3],[3,2,3,2,3]) + lex4 :: Eff '[OnDemandState [Int]] [Int] + lex4 = do + modify ((0::Int):) + onDemand lex4 + modify ((1::Int):) + onDemand (onDemand lex4 :: Eff '[OnDemandState [Int]] [Int]) + modify ((2::Int):) + modify ((3::Int):) + get + + +-- Edward's example plus exceptions +case_LazierState_ex5 :: Assertion +case_LazierState_ex5 = + let + -- the annotations below are needed for assertEqual + ex5Run :: Either [Int] () = fst . run $ runState (undefined::[Int]) (runError lex5) + ex51Run :: Either [Int] ((), [Int]) = run $ runError $ runState (undefined::[Int]) lex5 + in + assertEqual "OnDemandState ex5" (Left ones) ex5Run + >> assertEqual "OnDemandState ex51" (Left ones) ex51Run + where + ones = take 5 $ repeat (1::Int) + lex31 :: Member (OnDemandState [Int]) r => Eff r () + lex31 = do + onDemand (lex31 :: Eff '[OnDemandState [Int]] ()) + modify ((1::Int):) + + lex5 = do + lex31 + x <- get + throwError ((take 5 x)::[Int]) + +case_LazierState_st :: Assertion +case_LazierState_st = let + stF :: ((Int,Int,Int),Int) = run $ runState (0::Int) st + stB0 :: ((Int,Int,Int),Int) = runStateBack0 st + stB :: ((Int,Int,Int),Int) = runStateBack st + in + assertEqual "OnDemandState stF" ((0,1,3),4) stF + >> assertEqual "OnDemandState stB0" ((1,2,4),1) stB0 + >> assertEqual "OnDemandState stB" ((1,2,4),1) stB + where + st = do + x <- get + put (1::Int) + put (1::Int) + y <- get + put (2::Int) + put (10::Int) + put (3::Int) + z <- get + put (4::Int) + return (x,y,z) + +case_LazierState_ones :: Assertion +case_LazierState_ones = + let ones :: [Int] = snd $ runStateBack $ do + s <- get + 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 i (doThing $ modify f)) @=? Just ((), i + 1) + where + i = 0 :: Int + f = succ :: Int -> Int diff --git a/test/Control/Eff/State/Strict/Test.hs b/test/Control/Eff/State/Strict/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/State/Strict/Test.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.State.Strict.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Exception +import Control.Eff.State.Strict +import Control.Eff.Reader.Strict +import Control.Eff.Writer.Strict +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Strict1_State_runState :: Assertion +case_Strict1_State_runState = let + (r, ()) = run + $ runState undefined + $ getVoid + >> putVoid undefined + >> putVoid () + in + assertUndefined r + where + getVoid :: Eff '[State ()] () + getVoid = get + + putVoid :: () -> Eff '[State ()] () + putVoid = put + +case_Strict1_State_ts1 :: Assertion +case_Strict1_State_ts1 = (10,10) @=? (run (runState (0::Int) ts1)) + where + ts1 = do + put (10 ::Int) + x <- get + return (x::Int) + +case_Strict1_State_ts11 :: Assertion +case_Strict1_State_ts11 = + (10,10) @=? (run (runStateR (0::Int) ts11)) + where + ts11 = do + tell (10 ::Int) + x <- ask + return (x::Int) + +case_Strict1_State_ts2 :: Assertion +case_Strict1_State_ts2 = (30::Int,20::Int) @=? + (run (runState (0::Int) ts2)) + where + ts2 = do + put (10::Int) + x <- get + put (20::Int) + y <- get + return (x+y) + +case_Strict1_State_ts21 :: Assertion +case_Strict1_State_ts21 = (30::Int,20::Int) @=? + (run (runStateR (0::Int) ts21)) + where + ts21 = do + tell (10::Int) + x <- ask + tell (20::Int) + y <- ask + return (x+y) + +tes1 :: (Member (State Int) r + , Member (Exc [Char]) r) => Eff r b +tes1 = do + incr + throwError "exc" + where + incr = get >>= put . (+ (1::Int)) + +case_Strict1_State_ter1 :: Assertion +case_Strict1_State_ter1 = (Left "exc" :: Either String Int,2) @=? + (run $ runState (1::Int) (runError tes1)) + +case_Strict1_State_ter2 :: Assertion +case_Strict1_State_ter2 = (Left "exc" :: Either String (Int,Int)) @=? + (run $ runError (runState (1::Int) tes1)) + +teCatch :: Member (Exc String) r => Eff r a -> Eff r [Char] +teCatch m = catchError (m >> return "done") (\e -> return (e::String)) + +case_Strict1_State_ter3 :: Assertion +case_Strict1_State_ter3 = (Right "exc" :: Either String String,2) @=? + (run $ runState (1::Int) (runError (teCatch tes1))) + +case_Strict1_State_ter4 :: Assertion +case_Strict1_State_ter4 = (Right ("exc",2) :: Either String (String,Int)) @=? + (run $ runError (runState (1::Int) (teCatch tes1))) + +case_Strict1_State_monadBaseControl :: Assertion +case_Strict1_State_monadBaseControl = runLift (runState i (doThing $ modify f)) @=? + Just ((), i + 1) + where + i = 0 :: Int + f = succ :: Int -> Int diff --git a/test/Control/Eff/Test.hs b/test/Control/Eff/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Test.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Control.Eff.Test (testGroups) where + +import Test.HUnit hiding (State) +import Test.QuickCheck +import Control.Eff +import Control.Eff.Reader.Strict +import Control.Eff.State.Strict +import Control.Eff.Exception +import qualified Control.Exception as Exc +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +testGroups = [ $(testGroupGenerator) ] + +prop_NestedEff :: Property +prop_NestedEff = forAll arbitrary (\x -> property (qu x == x)) + where + qu :: Bool -> Bool + qu x = run $ runReader readerId (readerAp x) + + readerAp :: Bool -> Eff '[Reader (Eff '[Reader Bool] Bool)] Bool + readerAp x = do + f <- ask + return . run $ runReader x f + + readerId :: Eff '[Reader Bool] Bool + readerId = do + x <- ask + return x + +-- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved. +case_Lift_building :: Assertion +case_Lift_building = runLift possiblyAmbiguous + where + possiblyAmbiguous :: (Monad m, Lifted m r) => Eff r () + possiblyAmbiguous = lift $ return () + +case_Lift_tl1r :: Assertion +case_Lift_tl1r = do + ((), output) <- catchOutput tl1r + assertOutput "Test tl1r" [show input] output + where + input = (5::Int) + -- tl1r :: IO () + tl1r = runLift (runReader input tl1) + where + tl1 = ask >>= \(x::Int) -> lift . print $ x + +case_Lift_tMd' :: Assertion +case_Lift_tMd' = do + (actualResult, actualOutput) <- catchOutput tMd' + let expected = (output, map show input) + assertEqual "Test mapMdebug using Lift" expected (actualResult, lines actualOutput) + where + input = [1..5] + val = (10::Int) + output = map (+ val) input + + tMd' = runLift $ runReader val $ mapMdebug' f input + where f x = ask `add` return x + + -- Re-implemenation of mapMdebug using Lifting + -- The signature is inferred + mapMdebug' :: (Show a, Lifted IO r) => + (a -> Eff r b) -> [a] -> Eff r [b] + mapMdebug' _f [] = return [] + mapMdebug' f (h:t) = do + lift $ print h + h' <- f h + t' <- mapMdebug' f t + return (h':t') + +-- tests from +data MyException = MyException String deriving (Show) +instance Exc.Exception MyException + +exfn :: Lifted IO r => Bool -> Eff r Bool +exfn True = lift . Exc.throw $ (MyException "thrown") +exfn False = return True + +testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s) +test1 m = do runLift (tf m True) >>= print; runLift (tf m False) >>= print +tf m x = runReader (x::Bool) . runState ([]::[String]) $ m + +runErrorStr = runError @String + +case_catchDynE_test1 :: Assertion +case_catchDynE_test1 = do + ((), actual) <- catchOutput $ test1 (testc m) + let expected = [ "(\"thrown\",[\"begin\"])" + , "(\"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test1: exception shouldn't drop Writer's state" + expected actual + where + -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- + -- that is, an exception will drop the Writer's state, even if that + -- exception is caught. Here, the state is preserved! + -- So, this is an advantage over MTL! + m = do + modify ("begin":) + x <- ask + r <- exfn x + modify ("end":) + return r + +-- Let us use an Error effect instead +case_catchDynE_test1' :: Assertion +case_catchDynE_test1' = do + ((), actual') <- catchOutput $ test1 (runErrorStr (testc m)) + let expected' = [ "(Left \"thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test1': Error shouldn't drop Writer's state" + expected' actual' + where + -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- + -- that is, an exception will drop the Writer's state, even if that + -- exception is caught. Here, the state is preserved! + -- So, this is an advantage over MTL! + m = do + modify ("begin":) + x <- ask + r <- exfn x + modify ("end":) + return r + + exfn True = throwError $ ("thrown") + exfn False = return True +-- Now, the behavior of the dynamic Exception and Error effect is consistent. +-- The state is preserved. Before it wasn't. + +case_catchDynE_test2 :: Assertion +case_catchDynE_test2 = do + ((), actual) <- catchOutput $ test1 (runErrorStr (testc m)) + let expected = [ "(Left \"thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test2: Error shouldn't drop Writer's state" + expected actual + where + m = do + modify ("begin":) + x <- ask + r <- exfn x `catchDynE` (\ (MyException s) -> throwError s) + modify ("end":) + return r + +-- Full recovery +case_catchDynE_test2' :: Assertion +case_catchDynE_test2' = do + ((), actual) <- catchOutput $ test1 (runErrorStr (testc m)) + let expected = [ "(Right \"False\",[\"end\",\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test2': Fully recover from errors" + expected actual + where + m = do + modify ("begin":) + x <- ask + r <- exfn x `catchDynE` (\ (MyException _s) -> return False) + modify ("end":) + return r + +-- Throwing within a handler +case_catchDynE_test3 :: Assertion +case_catchDynE_test3 = do + ((), actual) <- catchOutput $ test1 (runErrorStr (testc m)) + let expected = [ "(Right \"rethrow:thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test3: Throwing within a handler" + expected actual + where + m = do + modify ("begin":) + x <- ask + r <- exfn x `catchDynE` (\ (MyException s) -> + lift . Exc.throw . MyException $ + ("rethrow:" ++ s)) + modify ("end":) + return r + +-- Implement the transactional behavior: when the exception is raised, +-- the state is rolled back to what it existed at the entrance to +-- the catch block. +-- This is the ``scoping behavior'' of `Handlers in action' +case_catchDynE_tran :: Assertion +case_catchDynE_tran = do + ((), actual1) <- catchOutput $ test1 m1 + ((), actual2) <- catchOutput $ test1 m2 + let expected1 = ["(\"thrown\",[\"init\"])" + ,"(\"True\",[\"end\",\"begin\",\"init\"])"] + let expected2 = ["(\"thrown\",[\"begin\",\"init\"])" + ,"(\"True\",[\"end\",\"begin\",\"init\"])"] + assertOutput "catchDynE: tran: Transactional behaviour" expected1 actual1 + >> assertOutput "catchDynE: tran: usual behaviour" expected2 actual2 + where + m1 = do + modify ("init":) + testc (transactionState (TxState :: TxState [String]) m) + m2 = do + modify ("init":) + testc m + m = do + modify ("begin":) + x <- ask + r <- exfn x + modify ("end":) + return r diff --git a/test/Control/Eff/Trace/Test.hs b/test/Control/Eff/Trace/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Trace/Test.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Trace.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Reader.Strict +import Control.Eff.Trace +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Trace_tdup :: Assertion +case_Trace_tdup = do + ((), actual) <- catchOutput tdup + assertEqual "Trace: duplicate layers" + ["Asked: 20", "Asked: 10"] (lines actual) + where + tdup = runTrace $ runReader (10::Int) m + where + m = do + runReader (20::Int) tr + tr + tr = do + v <- ask + trace $ "Asked: " ++ show (v::Int) + +case_Trace_tMd :: Assertion +case_Trace_tMd = do + (actualResult, actualOutput) <- catchOutput tMd + assertEqual "Trace: higher-order effectful function" + (map (+ val) input, map (("mapMdebug: " ++) . show) input) + (actualResult, lines actualOutput) + where + val = (10::Int) + input = [1..5] + tMd = runTrace $ runReader val (mapMdebug f input) + where + f x = ask `add` return x + + -- Higher-order effectful function + -- The inferred type shows that the Trace affect is added to the effects + -- of r + mapMdebug:: (Show a, Member Trace r) => + (a -> Eff r b) -> [a] -> Eff r [b] + mapMdebug _f [] = return [] + mapMdebug f (h:t) = do + trace $ "mapMdebug: " ++ show h + h' <- f h + t' <- mapMdebug f t + return (h':t') diff --git a/test/Control/Eff/Writer/Lazy/Test.hs b/test/Control/Eff/Writer/Lazy/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Writer/Lazy/Test.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Writer.Lazy.Test (testGroups) where + +import Test.HUnit hiding (State) +import Test.QuickCheck + +import Control.Eff +import Control.Eff.Reader.Lazy +import Control.Eff.Writer.Lazy +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +testGroups = [ $(testGroupGenerator) ] + +addGet :: Member (Reader Int) r => Int -> Eff r Int +addGet x = ask >>= \i -> return (i+x) + +addN n = foldl (>>>) return (replicate n addGet) 0 + where f >>> g = (>>= g) . f + +case_Lazy1_Writer_rdwr :: Assertion +case_Lazy1_Writer_rdwr = (10, ["begin", "end"]) @=? + (run . runReader (1::Int) . runListWriter $ rdwr) + where + rdwr = do + tell "begin" + r <- addN 10 + tell "end" + return r + +prop_Lazy1_Writer_censor :: [Integer] -> Property +prop_Lazy1_Writer_censor l = + property + $ listE (mapM_ (tell . inc) l) == listE (censor inc $ mapM_ tell l) + where + inc :: Integer -> Integer + inc = (+1) + + listE :: Eff '[Writer Integer] () -> [Integer] + listE = snd . run . runListWriter + +case_Lazy1_Writer_runFirstWriter :: Assertion +case_Lazy1_Writer_runFirstWriter = let + ((), Just m) = run $ runFirstWriter $ mapM_ tell [(), undefined] + in + assertNoUndefined (m :: ()) + +case_Lazy1_Writer_runLastWriter :: Assertion +case_Lazy1_Writer_runLastWriter = let + ((), 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) diff --git a/test/Control/Eff/Writer/Strict/Test.hs b/test/Control/Eff/Writer/Strict/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Writer/Strict/Test.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Writer.Strict.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Writer.Strict +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_Strict1_Writer_runLastWriter :: Assertion +case_Strict1_Writer_runLastWriter = let + ((), 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) diff --git a/test/DoctestRun.hs b/test/DoctestRun.hs new file mode 100644 --- /dev/null +++ b/test/DoctestRun.hs @@ -0,0 +1,13 @@ +module DoctestRun where + +import Test.DocTest (doctest) + +runDocTest :: IO () +runDocTest = do + putStrLn "" + putStrLn "" + putStrLn "Doc Test..." + doctest ["-i", "-XFlexibleContexts", "-XMultiParamTypeClasses", "-XFlexibleInstances", "-XGADTs", "-XScopedTypeVariables", + "-isrc", "src/Control/Eff/QuickStart.hs"] + putStrLn "Doc Test OK" + putStrLn "" diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,160 +1,41 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -import Control.Exception (Exception, ErrorCall, catch) -import Control.Monad (void) -import Data.Typeable - -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 - -import Test.HUnit hiding (State) -import Test.QuickCheck - -import Control.Eff -import Control.Eff.Fail -import Control.Eff.Lift -import Control.Eff.Reader.Lazy as LazyR -import Control.Eff.State.Lazy as LazyS -import Control.Eff.Writer.Lazy as LazyW -import Control.Eff.Reader.Strict as StrictR -import Control.Eff.State.Strict as StrictS -import Control.Eff.Writer.Strict as StrictW - -withError :: a -> ErrorCall -> a -withError a _ = a - -assertUndefined :: a -> Assertion -assertUndefined a = catch (seq a $ assertFailure "") (withError $ return ()) +import Test.Framework (defaultMain, Test) -assertNoUndefined :: a -> Assertion -assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "") +import qualified Control.Eff.Test +import qualified Control.Eff.Coroutine.Test +import qualified Control.Eff.Example.Test +import qualified Control.Eff.Exception.Test +import qualified Control.Eff.Fresh.Test +import qualified Control.Eff.Logic.NDet.Test +import qualified Control.Eff.Operational.Test +import qualified Control.Eff.Reader.Lazy.Test +import qualified Control.Eff.Reader.Strict.Test +import qualified Control.Eff.State.Lazy.Test +import qualified Control.Eff.State.OnDemand.Test +import qualified Control.Eff.State.Strict.Test +import qualified Control.Eff.Trace.Test +import qualified Control.Eff.Writer.Lazy.Test +import qualified Control.Eff.Writer.Strict.Test +import DoctestRun (runDocTest) main :: IO () -main = defaultMain tests - -allEqual :: Eq a => [a] -> Bool -allEqual = all (uncurry (==)) . pairs - where - pairs l = zip l $ tail l - -safeLast [] = Nothing -safeLast l = Just $ last l - -testDocs :: [Integer] -> Property -testDocs l = let - (total1, ()) = run $ LazyS.runState 0 $ sumAll l - (last1, ()) = run $ LazyW.runLastWriter $ writeAll l - (total2, (last2, ())) = run $ LazyS.runState 0 $ LazyW.runLastWriter $ writeAndAdd l - (last3, (total3, ())) = run $ LazyW.runLastWriter $ LazyS.runState 0 $ writeAndAdd l - in allEqual [safeLast l, last1, last2, last3] - .&&. allEqual [sum l, total1, total2, total3] - where - writeAll :: (Typeable a, Member (LazyW.Writer a) e) - => [a] - -> Eff e () - writeAll = mapM_ LazyW.tell - - sumAll :: (Typeable a, Num a, Member (LazyS.State a) e) - => [a] - -> Eff e () - sumAll = mapM_ (LazyS.modify . (+)) - - writeAndAdd :: (Member (LazyW.Writer Integer) e, Member (LazyS.State Integer) e) - => [Integer] - -> Eff e () - writeAndAdd l = do - writeAll l - sumAll l - -testCensor :: [Integer] -> Property -testCensor l = property - $ listE (mapM_ (LazyW.tell . inc) l) == listE (LazyW.censor inc $ mapM_ LazyW.tell l) - where - inc :: Integer -> Integer - inc = (+1) - - listE :: Eff (LazyW.Writer Integer :> ()) () -> [Integer] - listE = fst . run . LazyW.runWriter (:) [] - -testReaderLaziness :: Assertion -testReaderLaziness = let e = run $ LazyR.runReader voidReader (undefined :: ()) - in assertNoUndefined (e :: ()) - where - voidReader = do - _ <- (LazyR.ask :: Eff (LazyR.Reader () :> ()) ()) - return () - -testReaderStrictness :: Assertion -testReaderStrictness = let e = run $ StrictR.runReader voidReader (undefined :: ()) - in assertUndefined (e :: ()) - where - voidReader = do - _ <- (StrictR.ask :: Eff (StrictR.Reader () :> ()) ()) - return () - -testStateLaziness :: Assertion -testStateLaziness = let (r, ()) = run - $ LazyS.runState undefined - $ getVoid - >> putVoid undefined - >> putVoid () - in assertNoUndefined r - where - getVoid :: Eff (LazyS.State () :> ()) () - getVoid = LazyS.get - - putVoid :: () -> Eff (LazyS.State () :> ()) () - putVoid = LazyS.put - -testStateStrictness :: Assertion -testStateStrictness = let (r, ()) = run - $ StrictS.runState undefined - $ getVoid - >> putVoid undefined - >> putVoid () - in assertUndefined r - where - getVoid :: Eff (StrictS.State () :> ()) () - getVoid = StrictS.get - - putVoid :: () -> Eff (StrictS.State () :> ()) () - putVoid = StrictS.put - -testLastWriterLaziness :: Assertion -testLastWriterLaziness = let (Just m, ()) = run $ LazyW.runLastWriter $ mapM_ LazyW.tell [undefined, ()] - in assertNoUndefined (m :: ()) - -testLastWriterStrictness :: Assertion -testLastWriterStrictness = let (Just m, ()) = run $ StrictW.runLastWriter $ mapM_ StrictW.tell [undefined, ()] - in assertUndefined (m :: ()) - -testFirstWriterLaziness :: Assertion -testFirstWriterLaziness = let (Just m, ()) = run $ LazyW.runFirstWriter $ mapM_ LazyW.tell [(), undefined] - in assertNoUndefined (m :: ()) - -testFailure :: Assertion -testFailure = - let go :: Eff (Fail :> StrictW.Writer Int :> ()) Int - -> Int - go = fst . run . StrictW.runWriter (+) 0 . ignoreFail - ret = go $ do - StrictW.tell (1 :: Int) - StrictW.tell (2 :: Int) - StrictW.tell (3 :: Int) - die - StrictW.tell (4 :: Int) - return 5 - in assertEqual "Fail should stop writing" 6 ret +main = do + runDocTest + defaultMain testGroups -tests = - [ testProperty "Documentation example." testDocs - , testCase "Test runReader laziness." testReaderLaziness - , testCase "Test runReader strictness." testReaderStrictness - , testCase "Test runState laziness." testStateLaziness - , testCase "Test runState strictness." testStateStrictness - , testCase "Test runLastWriter laziness." testLastWriterLaziness - , testCase "Test runLastWriter strictness." testLastWriterStrictness - , testCase "Test runFirstWriter laziness." testFirstWriterLaziness - , testCase "Test failure effect." testFailure - ] +testGroups :: [Test] +testGroups = [] + ++ Control.Eff.Test.testGroups + ++ Control.Eff.Coroutine.Test.testGroups + ++ Control.Eff.Example.Test.testGroups + ++ Control.Eff.Exception.Test.testGroups + ++ Control.Eff.Fresh.Test.testGroups + ++ Control.Eff.Logic.NDet.Test.testGroups + ++ Control.Eff.Operational.Test.testGroups + ++ Control.Eff.Reader.Lazy.Test.testGroups + ++ Control.Eff.Reader.Strict.Test.testGroups + ++ Control.Eff.State.Lazy.Test.testGroups + ++ Control.Eff.State.OnDemand.Test.testGroups + ++ Control.Eff.State.Strict.Test.testGroups + ++ Control.Eff.Trace.Test.testGroups + ++ Control.Eff.Writer.Lazy.Test.testGroups + ++ Control.Eff.Writer.Strict.Test.testGroups diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,48 @@ +module Utils where + +import Control.Exception (ErrorCall, catch) +import Control.Monad +import Control.Monad.Trans.Control + +import System.IO.Silently +import Data.Tuple (swap) + +import Test.HUnit hiding (State) + +-- | capture stdout +-- [[https://stackoverflow.com/a/11128420][source]] +catchOutput :: IO a -> IO (a, String) +catchOutput f = swap `fmap` capture f + +withError :: a -> ErrorCall -> a +withError a _ = a + +assertUndefined :: a -> Assertion +assertUndefined a = catch (seq a $ assertFailure "") (withError $ return ()) + +assertNoUndefined :: a -> Assertion +assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "") + +assertOutput :: String -> [String] -> String -> Assertion +assertOutput msg expected actual = assertEqual msg expected (lines actual) + +runAsserts :: (String -> a -> e -> Assertion) -> [(String, e, a)] -> Assertion +runAsserts run cases = forM_ cases $ \(prop, test, res) -> run prop res test + +allEqual :: Eq a => [a] -> Bool +allEqual = all (uncurry (==)) . pairs + where + pairs l = zip l $ tail l + +safeLast :: [a] -> Maybe a +safeLast [] = Nothing +safeLast l = Just $ last l + +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