diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,14 @@ -# Revision history for bluefin-algae - -## 0.1.0.1 -- 2024-05-04 - -- Include `README.md` in the cabal distribution. - -## 0.1.0.0 -- 2024-05-04 - -- First version. Released on an unsuspecting world. +# Revision history for bluefin-algae + +## 0.1.0.2 -- 2025-09-15 + +- Compatibility with GHC 9.12: + + Enable `DataKinds` to silence warnings + +## 0.1.0.1 -- 2024-05-04 + +- Include `README.md` in the cabal distribution. + +## 0.1.0.0 -- 2024-05-04 + +- First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,20 +1,20 @@ -Copyright (c) 2024 Li-yao Xia - -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. +Copyright (c) 2024 Li-yao Xia + +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 --- a/README.md +++ b/README.md @@ -1,200 +1,202 @@ -Named algebraic effect handlers in Bluefin -========================================== - -This package leverages the delimited continuations primitives added in -GHC 9.6 to implement algebraic effects in the Bluefin effect system. - -Algebraic effects are a minimalistic basis for **user-defined effects**. -Using algebraic effects, we can reimplement, from scratch, effects that -were built-in the Bluefin library, and more. - -This is an experimental project. There are surprising performance -characteristics which may be problematic for practical applications. -[Details down below.](#quadratic-behavior-of-non-tail-recursion) - -## Free monads in `IO` - -An algebraic effect library is basically a free monad library with support for -extensible effects. - -Effect handlers---the core primitive of algebraic effects---are conceptually -folds of trees, aka. -[`iter` in free](https://hackage.haskell.org/package/free-5.2/docs/Control-Monad-Free.html) -or [`cata` in recursion-schemes](https://hackage.haskell.org/package/recursion-schemes-5.2.2.5/docs/Data-Functor-Foldable.html#v:cata). - -Effect systems---such as Bluefin---enable combinations of effects within a -single parameterized monad. Bluefin Algae seamlessly integrates with Bluefin's -infrastructure in order to compose algebraic effects. - -The main novelties in Bluefin Algae are: - -- computations use the same representation as `IO` (`State# s -> (# State# s, a #)`) - instead of recursive types or continuation-passing encodings. - This is possible thanks to the recently available primitives for delimited - continuations. - -- thanks to Bluefin, effects are statically scoped: performing an operation - requires a handle which identifies a specific handler. - - This enables new forms of abstraction boundaries. - A function `Eff s a -> Eff s a` cannot handle the operations of its argument. - The argument must be explicitly parameterized by the handler to allow - handling by its caller: `(forall z. Handler f z -> Eff (z : s) a) -> Eff s a`. - -## Highlights - -### Concurrency - -In the following example, two threads yield a string back and forth, appending -a suffix every time. - -```haskell -import Bluefin.Algae.Coroutine - -pingpong :: Eff ss String -pingpong = withCoroutine coThread mainThread - where - coThread z0 h = do - z1 <- yield h (z0 ++ "pong") - z2 <- yield h (z1 ++ "dong") - yield h (z2 ++ "bong") - mainThread h = do - s1 <- yield h "ping" - s2 <- yield h (s1 ++ "ding") - s3 <- yield h (s2 ++ "bing") - pure s3 - --- runPureEff pingpong == "pingpongdingdongbingbong" -``` - -Note that `coThread` and `mainThread` are just `IO` computations under the hood. -And we can interleave their executions without native multithreading. This is the -power of delimited continuations. - -### Nondeterminism - -With the ability to interrupt and resume operations freely, we can do -backtracking search in the `Eff` monad. - -```haskell -import Bluefin.Algae.NonDeterminism as NonDet - -pythagoras :: z :> zz => Handler Choice z -> Eff zz (Int, Int, Int) -pythagoras choice = do - x <- pick choice [1 .. 10] - y <- pick choice [1 .. 10] - z <- pick choice [1 .. 10] - assume choice (x .^ 2 + y .^ 2 == z .^ 2) - pure (x, y, z) - - where (.^) = (Prelude.^) :: Int -> Int -> Int - --- runPureEff (NonDet.toList pythagoras) == [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] -``` - -#### Backtracking and state - -Resuming continuations more than once exposes the impurity of the -implementation of the built-in state effect in `Bluefin.State`. -Here is a program using nondeterminism and state. There are two branches -(`choose`), both modify the state (`incr`). - -```haskell -import qualified Bluefin.State as B - -nsExampleB :: [Int] -nsExampleB = runPureEff $ NonDet.toList \choice -> - snd <$> B.runState 0 \state -> do - _ <- choose choice True False - B.modify (+ 1) state - --- nsExampleB == [1,2] -``` - -The state handler (`runState`) is under the nondeterminism handler -(`NonDet.toList`), which suggests a state-passing interpetation, where the -original state is restored upon backtracking (both branches return `1`): - -```haskell -nsExamplePure :: [Int] -nsExamplePure = runPureEff $ NonDet.toList \choice -> - let state = 0 -- initial state - _ <- choose choice True False - let state' = state' + 1 -- modify' (+ 1) - pure state' -- (snd <$> runState) returns the final state - --- nsExamplePure == [1,1] -``` - -Because `Bluefin.State` is backed by `IORef`, the mutation persists -through backtracking (the second branch returns `2` in the first example). - -In comparison, the state effect defined using algebraic effects -(`Bluefin.Algae.State`) has the state-passing semantics. - -```haskell -import qualified Bluefin.Algae.State as A - -nsExampleA :: [Int] -nsExampleA = runPureEff $ NonDet.toList \choice -> - A.execState 0 \state -> do - _ <- choose choice True False - A.modify' (+ 1) state - --- nsExampleA == [1,1] -``` - -### Truly scoped exceptions. - -The scoped exceptions from `Bluefin.Exception` are not completely scoped because -they can be observed by `bracket`. That is probably the right behavior in practice, -but makes the semantics of Bluefin less clear. For the sake of science, -`Bluefin.Algae.Exception` provides truly scoped exceptions, and implements -"`bracket`-observable" scoped exceptions on top. - -## Lowlights - -### Quadratic behavior of non-tail recursion. - -For example, the following recursive counter will take time quadratic in `n` -because every call of `modify'` traverses the call stack to find its handler -and capture the continuation. - -```haskell -leftRecCounter :: z :> zz => Handler (State Int) z -> Int -> Eff zz () -leftRecCounter _state 0 = pure () -leftRecCounter state n = do - leftRecCounter state (n - 1) - modify' state (+ 1) -``` - -## Comparison - -### Bluefin - -The Bluefin effect system provides a well-scoped [handle pattern][handle]. -Unlike algebraic effects with which other computational effects can be -user-defined, Bluefin provides a collection of built-in effects -(state, exceptions, coroutines). - -Without delimited continuations, only tail-resumptive algebraic effect handlers -are expressible in Bluefin. Those are effect handlers restricted to the -following form, which is equivalent to type `forall r. f r -> Eff ss r`. - -```haskell -(\e k -> _ >>= k) - :: forall r. f r -> (r -> Eff ss a) -> Eff ss a -``` - -[handle]: https://jaspervdj.be/posts/2018-03-08-handle-pattern.html - -## More reading - -Named effect handlers are described in the literature in: - -- [Binders by day, labels by night](https://maciejpirog.github.io/papers/binders-labels.pdf) - by Dariusz Biernacki et al. -- [First-class names for effect handlers](https://www.microsoft.com/en-us/research/uploads/prod/2021/05/namedh-tr.pdf) - by Ningning Xie et al. (impemented in the [Koka](https://koka-lang.github.io/koka/doc/index.html) language) -- [Effects, capabilities, and Boxes](https://dl.acm.org/doi/pdf/10.1145/3527320) - by Jonathan Brachtäuser et al. +Named algebraic effect handlers in Bluefin +========================================== + +[![Hackage](https://img.shields.io/hackage/v/bluefin-algae.svg)](https://hackage.haskell.org/package/bluefin-algae) + +This package leverages the delimited continuations primitives added in +GHC 9.6 to implement algebraic effects in the Bluefin effect system. + +Algebraic effects are a minimalistic basis for **user-defined effects**. +Using algebraic effects, we can reimplement, from scratch, effects that +were built-in the Bluefin library, and more. + +This is an experimental project. There are surprising performance +characteristics which may be problematic for practical applications. +[Details down below.](#quadratic-behavior-of-non-tail-recursion) + +## Free monads in `IO` + +An algebraic effect library is basically a free monad library with support for +extensible effects. + +Effect handlers—the core primitive of algebraic effects—are conceptually +folds of trees, aka. +[`iter` in free](https://hackage.haskell.org/package/free-5.2/docs/Control-Monad-Free.html) +or [`cata` in recursion-schemes](https://hackage.haskell.org/package/recursion-schemes-5.2.2.5/docs/Data-Functor-Foldable.html#v:cata). + +Effect systems—such as Bluefin—enable combinations of effects within a +single parameterized monad. Bluefin Algae seamlessly integrates with Bluefin's +infrastructure in order to compose algebraic effects. + +The main novelties in Bluefin Algae are: + +- computations use the same representation as `IO` (`State# s -> (# State# s, a #)`) + instead of recursive types or continuation-passing encodings. + This is possible thanks to the recently available primitives for delimited + continuations. + +- thanks to Bluefin, effects are statically scoped: performing an operation + requires a handle which identifies a specific handler. + + This enables new forms of abstraction boundaries. + A function `Eff s a -> Eff s a` cannot handle the operations of its argument. + The argument must be explicitly parameterized by the handler to allow + handling by its caller: `(forall z. Handler f z -> Eff (z : s) a) -> Eff s a`. + +## Highlights + +### Concurrency + +In the following example, two threads yield a string back and forth, appending +a suffix every time. + +```haskell +import Bluefin.Algae.Coroutine + +pingpong :: Eff ss String +pingpong = withCoroutine coThread mainThread + where + coThread z0 h = do + z1 <- yield h (z0 ++ "pong") + z2 <- yield h (z1 ++ "dong") + yield h (z2 ++ "bong") + mainThread h = do + s1 <- yield h "ping" + s2 <- yield h (s1 ++ "ding") + s3 <- yield h (s2 ++ "bing") + pure s3 + +-- runPureEff pingpong == "pingpongdingdongbingbong" +``` + +Note that `coThread` and `mainThread` are just `IO` computations under the hood. +And we can interleave their executions without native multithreading. This is the +power of delimited continuations. + +### Nondeterminism + +With the ability to interrupt and resume operations freely, we can do +backtracking search in the `Eff` monad. + +```haskell +import Bluefin.Algae.NonDeterminism as NonDet + +pythagoras :: z :> zz => Handler Choice z -> Eff zz (Int, Int, Int) +pythagoras choice = do + x <- pick choice [1 .. 10] + y <- pick choice [1 .. 10] + z <- pick choice [1 .. 10] + assume choice (x .^ 2 + y .^ 2 == z .^ 2) + pure (x, y, z) + + where (.^) = (Prelude.^) :: Int -> Int -> Int + +-- runPureEff (NonDet.toList pythagoras) == [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] +``` + +#### Backtracking and state + +Resuming continuations more than once exposes the impurity of the +implementation of the built-in state effect in `Bluefin.State`. +Here is a program using nondeterminism and state. There are two branches +(`choose`), both modify the state (`incr`). + +```haskell +import qualified Bluefin.State as B + +nsExampleB :: [Int] +nsExampleB = runPureEff $ NonDet.toList \choice -> + snd <$> B.runState 0 \state -> do + _ <- choose choice True False + B.modify (+ 1) state + +-- nsExampleB == [1,2] +``` + +The state handler (`runState`) is under the nondeterminism handler +(`NonDet.toList`), which suggests a state-passing interpetation, where the +original state is restored upon backtracking (both branches return `1`): + +```haskell +nsExamplePure :: [Int] +nsExamplePure = runPureEff $ NonDet.toList \choice -> + let state = 0 -- initial state that was passed to runState + _ <- choose choice True False + let state' = state + 1 -- modify (+ 1) + pure state' -- (snd <$> runState) returns the final state + +-- nsExamplePure == [1,1] +``` + +Because `Bluefin.State` is backed by `IORef`, the mutation persists +through backtracking (the second branch returns `2` in the first example). + +In comparison, the state effect defined using algebraic effects +(`Bluefin.Algae.State`) has the state-passing semantics. + +```haskell +import qualified Bluefin.Algae.State as A + +nsExampleA :: [Int] +nsExampleA = runPureEff $ NonDet.toList \choice -> + A.execState 0 \state -> do + _ <- choose choice True False + A.modify (+ 1) state + +-- nsExampleA == [1,1] +``` + +### Truly scoped exceptions. + +The scoped exceptions from `Bluefin.Exception` are not completely scoped because +they can be observed by `bracket`. That is probably the right behavior in practice, +but makes the semantics of Bluefin less clear. For the sake of science, +`Bluefin.Algae.Exception` provides truly scoped exceptions, and implements +"`bracket`-observable" scoped exceptions on top. + +## Lowlights + +### Quadratic behavior of non-tail recursion. + +For example, the following recursive counter will take time quadratic in `n` +because every call of `modify` traverses the call stack to find its handler +and capture the continuation. + +```haskell +leftRecCounter :: z :> zz => Handler (State Int) z -> Int -> Eff zz () +leftRecCounter _state 0 = pure () +leftRecCounter state n = do + leftRecCounter state (n - 1) + modify state (+ 1) +``` + +## Comparison + +### Bluefin + +The Bluefin effect system provides a well-scoped [handle pattern][handle]. +Unlike algebraic effects with which other computational effects can be +user-defined, Bluefin provides a collection of built-in effects +(state, exceptions, coroutines). + +Without delimited continuations, only tail-resumptive algebraic effect handlers +are expressible in Bluefin. Those are effect handlers restricted to the +following form, which is equivalent to type `forall r. f r -> Eff ss r`. + +```haskell +(\e k -> _ >>= k) + :: forall r. f r -> (r -> Eff ss a) -> Eff ss a +``` + +[handle]: https://jaspervdj.be/posts/2018-03-08-handle-pattern.html + +## More reading + +Named effect handlers are described in the literature in: + +- [Binders by day, labels by night](https://maciejpirog.github.io/papers/binders-labels.pdf) + by Dariusz Biernacki et al. +- [First-class names for effect handlers](https://www.microsoft.com/en-us/research/uploads/prod/2021/05/namedh-tr.pdf) + by Ningning Xie et al. (impemented in the [Koka](https://koka-lang.github.io/koka/doc/index.html) language) +- [Effects, capabilities, and Boxes](https://dl.acm.org/doi/pdf/10.1145/3527320) + by Jonathan Brachtäuser et al. diff --git a/bench/quadratic-counter.hs b/bench/quadratic-counter.hs --- a/bench/quadratic-counter.hs +++ b/bench/quadratic-counter.hs @@ -1,50 +1,50 @@ -{-# LANGUAGE - BangPatterns, - BlockArguments, - RankNTypes, - ScopedTypeVariables, - TypeOperators #-} - --- Algebraic operations require traversing the stack, --- which causes this quadratic behavior in left-recursive functions. - -import Test.Tasty.Bench (Benchmark, Benchmarkable, bcompareWithin, bench, bgroup, defaultMain, nf) -import Bluefin.Eff (Eff, type (:>), runPureEff) -import Bluefin.Algae -import Bluefin.Algae.State - --- Left recursive counter -leftRecCounter :: z :> zz => Handler (State Int) z -> Int -> Eff zz () -leftRecCounter _state 0 = pure () -leftRecCounter state n = do - leftRecCounter state (n - 1) - modify state (+ 1) - --- Benchmarking harness - --- @bcompareQuadratic name tolerance factor f@: --- Assert that @f factor@ runs @factor * factor@ times slower than @f 1@, --- within a relative tolerance interval @[1 - tolerance, 1 + tolerance]@. -bcompareQuadratic :: String -> Double -> Int -> (Int -> Benchmarkable) -> Benchmark -bcompareQuadratic = bcompareAsymptotic (\x -> x * x) - --- Compare the benchmarks (f 1) and (f factor) with respect to a given growth function -bcompareAsymptotic :: (Double -> Double) -> String -> Double -> Int -> (Int -> Benchmarkable) -> Benchmark -bcompareAsymptotic growth name tolerance factor f = bgroup name - [ bench "baseline" (f 1) - , bcompareWithin lower upper (name ++ ".baseline") $ - bench ("x" ++ show factor) (f factor) - ] where - factor2 = growth (fromIntegral factor) - lower = (1 - tolerance) * factor2 - upper = (1 + tolerance) * factor2 - -runQuadraticCounter :: Int -> Int -runQuadraticCounter n = runPureEff $ execState 0 \state -> leftRecCounter state n - -testQuadraticCounter :: Benchmark -testQuadraticCounter = bcompareQuadratic "quadratic-counter" 0.2 10 (\factor -> - nf runQuadraticCounter (100 * factor)) - -main :: IO () -main = defaultMain [ testQuadraticCounter ] +{-# LANGUAGE + BangPatterns, + BlockArguments, + RankNTypes, + ScopedTypeVariables, + TypeOperators #-} + +-- Algebraic operations require traversing the stack, +-- which causes this quadratic behavior in left-recursive functions. + +import Test.Tasty.Bench (Benchmark, Benchmarkable, bcompareWithin, bench, bgroup, defaultMain, nf) +import Bluefin.Eff (Eff, type (:>), runPureEff) +import Bluefin.Algae +import Bluefin.Algae.State + +-- Left recursive counter +leftRecCounter :: z :> zz => Handler (State Int) z -> Int -> Eff zz () +leftRecCounter _state 0 = pure () +leftRecCounter state n = do + leftRecCounter state (n - 1) + modify state (+ 1) + +-- Benchmarking harness + +-- @bcompareQuadratic name tolerance factor f@: +-- Assert that @f factor@ runs @factor * factor@ times slower than @f 1@, +-- within a relative tolerance interval @[1 - tolerance, 1 + tolerance]@. +bcompareQuadratic :: String -> Double -> Int -> (Int -> Benchmarkable) -> Benchmark +bcompareQuadratic = bcompareAsymptotic (\x -> x * x) + +-- Compare the benchmarks (f 1) and (f factor) with respect to a given growth function +bcompareAsymptotic :: (Double -> Double) -> String -> Double -> Int -> (Int -> Benchmarkable) -> Benchmark +bcompareAsymptotic growth name tolerance factor f = bgroup name + [ bench "baseline" (f 1) + , bcompareWithin lower upper (name ++ ".baseline") $ + bench ("x" ++ show factor) (f factor) + ] where + factor2 = growth (fromIntegral factor) + lower = (1 - tolerance) * factor2 + upper = (1 + tolerance) * factor2 + +runQuadraticCounter :: Int -> Int +runQuadraticCounter n = runPureEff $ execState 0 \state -> leftRecCounter state n + +testQuadraticCounter :: Benchmark +testQuadraticCounter = bcompareQuadratic "quadratic-counter" 0.2 10 (\factor -> + nf runQuadraticCounter (100 * factor)) + +main :: IO () +main = defaultMain [ testQuadraticCounter ] diff --git a/bluefin-algae.cabal b/bluefin-algae.cabal --- a/bluefin-algae.cabal +++ b/bluefin-algae.cabal @@ -1,74 +1,74 @@ -cabal-version: 3.4 -name: bluefin-algae -version: 0.1.0.1 -synopsis: - Algebraic effects and named handlers in Bluefin. -description: - A framework for user-defined effects powered by delimited continuations. -license: MIT -license-file: LICENSE -author: Li-yao Xia -maintainer: lysxia@gmail.com -copyright: Li-yao Xia 2024 -category: Control -build-type: Simple -extra-doc-files: CHANGELOG.md README.md -tested-with: - GHC == 9.6.4 - GHC == 9.8.2 - GHC == 9.10.1 - -common warnings - ghc-options: -Wall - -library - import: warnings - exposed-modules: - Bluefin.Algae - Bluefin.Algae.DynExn - Bluefin.Algae.DelCont - Bluefin.Exception.Dynamic - Bluefin.Algae.Reader - Bluefin.Algae.State - Bluefin.Algae.Exception - Bluefin.Algae.Exception.DynExn - Bluefin.Algae.NonDeterminism - Bluefin.Algae.Coroutine - reexported-modules: - Bluefin.Eff - build-depends: - bluefin >= 0.0.6 && < 0.1, - bluefin-internal < 0.1, - base >=4.18 && < 4.22 - hs-source-dirs: src - default-language: Haskell2010 - -test-suite main-test - import: warnings - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - build-depends: - base, - tasty, - tasty-hunit, - bluefin, - bluefin-algae - -test-suite quadratic-counter - import: warnings - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: quadratic-counter.hs - build-depends: - base, - tasty, - tasty-bench, - bluefin, - bluefin-algae - -source-repository head - type: git - location: https://github.com/Lysxia/bluefin-algae +cabal-version: 3.4 +name: bluefin-algae +version: 0.1.0.2 +synopsis: + Algebraic effects and named handlers in Bluefin. +description: + A framework for user-defined effects powered by delimited continuations. +license: MIT +license-file: LICENSE +author: Li-yao Xia +maintainer: lysxia@gmail.com +copyright: Li-yao Xia 2024 +category: Control +build-type: Simple +extra-doc-files: CHANGELOG.md README.md +tested-with: + GHC == 9.6.4 + GHC == 9.8.2 + GHC == 9.10.1 + GHC == 9.12.2 + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: + Bluefin.Algae + Bluefin.Algae.DynExn + Bluefin.Algae.DelCont + Bluefin.Exception.Dynamic + Bluefin.Algae.Reader + Bluefin.Algae.State + Bluefin.Algae.Exception + Bluefin.Algae.Exception.DynExn + Bluefin.Algae.NonDeterminism + Bluefin.Algae.Coroutine + reexported-modules: + Bluefin.Eff + build-depends: + bluefin >= 0.0.6 && < 0.1, + bluefin-internal < 0.2, + base >=4.18 && < 4.22 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite main-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + tasty, + tasty-hunit, + bluefin, + bluefin-algae + +benchmark quadratic-counter + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: quadratic-counter.hs + build-depends: + base, + tasty-bench, + bluefin, + bluefin-algae + +source-repository head + type: git + location: https://github.com/Lysxia/bluefin-algae diff --git a/src/Bluefin/Algae.hs b/src/Bluefin/Algae.hs --- a/src/Bluefin/Algae.hs +++ b/src/Bluefin/Algae.hs @@ -1,182 +1,183 @@ -{-# LANGUAGE - BangPatterns, - GADTs, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | = Algebraic effects and named handlers --- --- Algebraic effect handlers are a powerful framework for --- user-defined effects with a simple equational intuition. --- --- Algebraic effect handlers are expressive enough to define various effects --- from scratch. In comparison, the 'Bluefin.State.runState' handler from --- "Bluefin.State" requires mutable references (@IORef@), relying on @IO@'s --- built-in statefulness. In terms of pure expressiveness, delimited --- continuations are all you need. --- --- An "algebraic effect" is a signature for a set of operations which we --- represent with a GADT. For example, the "state effect" @State s@ contains --- two operations: @Get@ takes no parameter and returns a value of type @s@, --- and @Put@ takes a value of type @s@ and returns @()@. The constructors --- @Get@ and @Put@ are "uninterpreted operations": they only describe the types --- of arguments and results, with no intrinsic meaning. --- --- @ --- data 'Bluefin.Algae.State.State' s r where --- Get :: 'Bluefin.Algae.State.State' s s --- Put :: s -> 'Bluefin.Algae.State.State' s () --- @ --- --- Below is an example of a stateful computation: a term of some type @'Eff' zz a@ with --- a state handler @h :: 'Handler' ('Bluefin.Algae.State.State' s) z@ in scope (@z :> zz@). --- The @State@ operations can be called using 'call' and the state handler @h@. --- --- @ --- -- Increment a counter and return its previous value. --- incr :: z :> zz => 'Handler' ('Bluefin.Algae.State.State' Int) z -> 'Eff' zz Int --- incr h = do --- n <- get --- put (n + 1) --- pure n --- where --- get = 'call' h Get --- put s = 'call' h (Put s) --- @ --- --- We handle the state effect by giving an interpretation of the @Get@ and @Put@ --- operations, as a function @f :: 'HandlerBody' (State s) zz a@. --- --- To 'call' @Get@ or @Put@ is to call the function @f@ supplied by 'handle'. --- The following equations show how 'handle' propagates an interpretation --- @f@ throughout a computation that calls @Get@ and @Put@: --- --- @ --- 'handle' f (\\h -> 'call' h Get >>= k h) = f Get ('handle' f (\\h -> k h)) --- 'handle' f (\\h -> 'call' h (Put s) >>= k h) = f (Put s) ('handle' f (\\h -> k h)) --- 'handle' f (\\h -> pure r) = pure r --- @ --- --- With those equations, @'handle' f@ applied to the above @incr@ simplifies to: --- --- @ --- 'handle' f incr = --- f Get \\n -> --- f (Put (n+1)) \\() -> --- pure n --- @ --- --- === References --- --- - (2013) by Gordon D. Plotkin and Matija Pretnar. --- - (2021) by Ningning Xie, Youyou Cong, and Daan Leijen. -module Bluefin.Algae - ( AEffect - - -- * Simple interface - , HandlerBody - , Handler - , ScopedEff - , handle - , call - - -- * Cancellable continuations - -- $cancel - , HandlerBody' - , handle' - , continue - , cancel - ) where - -import Data.Kind (Type) -import Bluefin.Eff (Eff, Effects, type (:&), type (:>)) -import Bluefin.Algae.DelCont - --- | Algebraic effect. -type AEffect = Type -> Type - --- | Interpretation of an algebraic effect @f@: a function to handle the operations of @f@. -type HandlerBody :: AEffect -> Effects -> Type -> Type -type HandlerBody f ss a = (forall x. f x -> (x -> Eff ss a) -> Eff ss a) - --- | Generalization of 'HandlerBody' with cancellable continuations. -type HandlerBody' :: AEffect -> Effects -> Type -> Type -type HandlerBody' f ss a = (forall ss0 x. f x -> Continuation ss0 ss x a -> Eff ss a) - --- | Handler to call operations of the effect @f@. -type Handler :: AEffect -> Effects -> Type -data Handler f s where - MkHandler :: !(PromptTag ss a s) -> HandlerBody' f ss a -> Handler f s - --- | Effectful computation with in scope @ss@ and final result @a@, --- extended with a scoped algebraic effect @f@. --- --- This type guarantees that the handler of @f@ cannot escape its scope: --- the 'Eff' computation cannot smuggle it out. All of the uses of the handle --- will happen in the span of the 'ScopedEff' computation. -type ScopedEff f ss a = forall s. Handler f s -> Eff (s :& ss) a - --- | Handle operations of @f@. --- --- === Warning for exception-like effects --- --- If the handler might not call the continuation (like for an exception effect), and --- if the handled computation manages resources (e.g., opening files, transactions) --- prefer 'handle'' to trigger resource clean up with cancellable continuations. -handle :: - HandlerBody f ss a -> - ScopedEff f ss a -> - Eff ss a -handle h = handle' (\f k -> h f (continue k)) - --- | Generalization of 'handle' with cancellable continuations. -handle' :: - HandlerBody' f ss a -> - ScopedEff f ss a -> - Eff ss a -handle' h act = reset (\p -> act (MkHandler p h)) - --- | Call an operation of algebraic effect @f@ with a handler. -call :: s :> ss => Handler f s -> f a -> Eff ss a -call (MkHandler p h) op = shift0 p (\k -> h op k) - --- $cancel --- Cancellable continuations are useful to work with resource-management schemes --- with exception handlers such as 'Bluefin.Eff.bracket' --- --- Cancellable continuations should be called exactly once (via 'continue' or 'cancel'): --- --- - at least once to ensure resources are eventually freed (no leaks); --- - at most once to avoid use-after-free errors. --- --- Enforcing this requirement with linear types would be a welcome contribution. --- --- === Example --- --- ==== Problem --- --- Given 'Bluefin.Eff.bracket' and a @Fail@ effect, --- the simple 'Bluefin.Algae.handle' may cause resource leaks: --- --- @ --- 'Bluefin.Algae.handle' (\\_e _k -> pure Nothing) --- ('Bluefin.Eff.bracket' ex acquire release (\\_ -> 'call' h Fail)) --- @ --- --- 'Bluefin.Eff.bracket' is intended to ensure that the acquired resource is --- released even if the bracketed function throws an exception. However, when --- the @Fail@ operation is called, the handler @(\\_e _k -> pure Nothing)@ --- discards the continuation @_k@ which contains the exception handler --- installed by 'Bluefin.Eff.bracket'. --- The resource leaks because @release@ will never be called. --- --- ==== Solution --- --- Using 'handle'' instead lets us 'cancel' the continuation. --- --- @ --- 'handle'' (\\_e k -> 'cancel' k >> pure Nothing) --- ('Bluefin.Eff.bracket' acquire release (\\_ -> 'call' h Fail)) --- @ +{-# LANGUAGE + BangPatterns, + DataKinds, + GADTs, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | = Algebraic effects and named handlers +-- +-- Algebraic effect handlers are a powerful framework for +-- user-defined effects with a simple equational intuition. +-- +-- Algebraic effect handlers are expressive enough to define various effects +-- from scratch. In comparison, the 'Bluefin.State.runState' handler from +-- "Bluefin.State" requires mutable references (@IORef@), relying on @IO@'s +-- built-in statefulness. In terms of pure expressiveness, delimited +-- continuations are all you need. +-- +-- An "algebraic effect" is a signature for a set of operations which we +-- represent with a GADT. For example, the "state effect" @State s@ contains +-- two operations: @Get@ takes no parameter and returns a value of type @s@, +-- and @Put@ takes a value of type @s@ and returns @()@. The constructors +-- @Get@ and @Put@ are "uninterpreted operations": they only describe the types +-- of arguments and results, with no intrinsic meaning. +-- +-- @ +-- data 'Bluefin.Algae.State.State' s r where +-- Get :: 'Bluefin.Algae.State.State' s s +-- Put :: s -> 'Bluefin.Algae.State.State' s () +-- @ +-- +-- Below is an example of a stateful computation: a term of some type @'Eff' zz a@ with +-- a state handler @h :: 'Handler' ('Bluefin.Algae.State.State' s) z@ in scope (@z :> zz@). +-- The @State@ operations can be called using 'call' and the state handler @h@. +-- +-- @ +-- -- Increment a counter and return its previous value. +-- incr :: z :> zz => 'Handler' ('Bluefin.Algae.State.State' Int) z -> 'Eff' zz Int +-- incr h = do +-- n <- get +-- put (n + 1) +-- pure n +-- where +-- get = 'call' h Get +-- put s = 'call' h (Put s) +-- @ +-- +-- We handle the state effect by giving an interpretation of the @Get@ and @Put@ +-- operations, as a function @f :: 'HandlerBody' (State s) zz a@. +-- +-- To 'call' @Get@ or @Put@ is to call the function @f@ supplied by 'handle'. +-- The following equations show how 'handle' propagates an interpretation +-- @f@ throughout a computation that calls @Get@ and @Put@: +-- +-- @ +-- 'handle' f (\\h -> 'call' h Get >>= k h) = f Get ('handle' f (\\h -> k h)) +-- 'handle' f (\\h -> 'call' h (Put s) >>= k h) = f (Put s) ('handle' f (\\h -> k h)) +-- 'handle' f (\\h -> pure r) = pure r +-- @ +-- +-- With those equations, @'handle' f@ applied to the above @incr@ simplifies to: +-- +-- @ +-- 'handle' f incr = +-- f Get \\n -> +-- f (Put (n+1)) \\() -> +-- pure n +-- @ +-- +-- === References +-- +-- - (2013) by Gordon D. Plotkin and Matija Pretnar. +-- - (2021) by Ningning Xie, Youyou Cong, and Daan Leijen. +module Bluefin.Algae + ( AEffect + + -- * Simple interface + , HandlerBody + , Handler + , ScopedEff + , handle + , call + + -- * Cancellable continuations + -- $cancel + , HandlerBody' + , handle' + , continue + , cancel + ) where + +import Data.Kind (Type) +import Bluefin.Eff (Eff, Effects, type (:&), type (:>)) +import Bluefin.Algae.DelCont + +-- | Algebraic effect. +type AEffect = Type -> Type + +-- | Interpretation of an algebraic effect @f@: a function to handle the operations of @f@. +type HandlerBody :: AEffect -> Effects -> Type -> Type +type HandlerBody f ss a = (forall x. f x -> (x -> Eff ss a) -> Eff ss a) + +-- | Generalization of 'HandlerBody' with cancellable continuations. +type HandlerBody' :: AEffect -> Effects -> Type -> Type +type HandlerBody' f ss a = (forall ss0 x. f x -> Continuation ss0 ss x a -> Eff ss a) + +-- | Handler to call operations of the effect @f@. +type Handler :: AEffect -> Effects -> Type +data Handler f s where + MkHandler :: !(PromptTag ss a s) -> HandlerBody' f ss a -> Handler f s + +-- | Effectful computation with in scope @ss@ and final result @a@, +-- extended with a scoped algebraic effect @f@. +-- +-- This type guarantees that the handler of @f@ cannot escape its scope: +-- the 'Eff' computation cannot smuggle it out. All of the uses of the handle +-- will happen in the span of the 'ScopedEff' computation. +type ScopedEff f ss a = forall s. Handler f s -> Eff (s :& ss) a + +-- | Handle operations of @f@. +-- +-- === Warning for exception-like effects +-- +-- If the handler might not call the continuation (like for an exception effect), and +-- if the handled computation manages resources (e.g., opening files, transactions) +-- prefer 'handle'' to trigger resource clean up with cancellable continuations. +handle :: + HandlerBody f ss a -> + ScopedEff f ss a -> + Eff ss a +handle h = handle' (\f k -> h f (continue k)) + +-- | Generalization of 'handle' with cancellable continuations. +handle' :: + HandlerBody' f ss a -> + ScopedEff f ss a -> + Eff ss a +handle' h act = reset (\p -> act (MkHandler p h)) + +-- | Call an operation of algebraic effect @f@ with a handler. +call :: s :> ss => Handler f s -> f a -> Eff ss a +call (MkHandler p h) op = shift0 p (\k -> h op k) + +-- $cancel +-- Cancellable continuations are useful to work with resource-management schemes +-- with exception handlers such as 'Bluefin.Eff.bracket' +-- +-- Cancellable continuations should be called exactly once (via 'continue' or 'cancel'): +-- +-- - at least once to ensure resources are eventually freed (no leaks); +-- - at most once to avoid use-after-free errors. +-- +-- Enforcing this requirement with linear types would be a welcome contribution. +-- +-- === Example +-- +-- ==== Problem +-- +-- Given 'Bluefin.Eff.bracket' and a @Fail@ effect, +-- the simple 'Bluefin.Algae.handle' may cause resource leaks: +-- +-- @ +-- 'Bluefin.Algae.handle' (\\_e _k -> pure Nothing) +-- ('Bluefin.Eff.bracket' ex acquire release (\\_ -> 'call' h Fail)) +-- @ +-- +-- 'Bluefin.Eff.bracket' is intended to ensure that the acquired resource is +-- released even if the bracketed function throws an exception. However, when +-- the @Fail@ operation is called, the handler @(\\_e _k -> pure Nothing)@ +-- discards the continuation @_k@ which contains the exception handler +-- installed by 'Bluefin.Eff.bracket'. +-- The resource leaks because @release@ will never be called. +-- +-- ==== Solution +-- +-- Using 'handle'' instead lets us 'cancel' the continuation. +-- +-- @ +-- 'handle'' (\\_e k -> 'cancel' k >> pure Nothing) +-- ('Bluefin.Eff.bracket' acquire release (\\_ -> 'call' h Fail)) +-- @ diff --git a/src/Bluefin/Algae/Coroutine.hs b/src/Bluefin/Algae/Coroutine.hs --- a/src/Bluefin/Algae/Coroutine.hs +++ b/src/Bluefin/Algae/Coroutine.hs @@ -1,467 +1,467 @@ -{-# LANGUAGE - BangPatterns, - DataKinds, - GADTs, - KindSignatures, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | = Coroutines: yield as an algebraic effect --- --- == Iterators --- --- A simple use case of coroutines is as an expressive way of defining iterators. --- --- An iterator is just a program which yields values. The following example --- yields the integers 1, 2, 3, 4. --- --- @ --- range1to4 :: z :> zz => Handler (Coroutine Int ()) z -> Eff zz () --- range1to4 h = do --- 'yield' h 1 --- 'yield' h 2 --- 'yield' h 3 --- 'yield' h 4 --- @ --- --- The 'forCoroutine' handler is a "for" loop over an iterator, --- running the loop body for every yielded element. --- Here we collect the even values into a list stored in mutable @State@. --- --- @ --- filterEven :: z :> zz => Handler (State [Int]) z -> Eff zz () --- filterEven h = --- 'forCoroutine' range1to4 \\n -> --- if n \`mod\` 2 == 0 --- then modify h (n :) --- else pure () --- --- filterEvenResult :: [Int] --- filterEvenResult = runPureEff $ execState [] filterEven --- --- -- 1 and 3 are filtered out, 2 and 4 are pushed into the queue --- in that order, so they appear in reverse order. --- -- filterEvenResult == [4,2] --- @ --- --- == Cooperative concurrency --- --- Coroutines are "cooperative threads", passing control to other coroutines --- with explicit 'yield' calls. --- --- In the following example, two threads yield a string back and forth, --- appending a suffix every time. --- --- @ --- pingpong :: Eff ss String --- pingpong = 'withCoroutine' coThread mainThread --- where --- coThread z0 h = do --- z1 <- 'yield' h (z0 ++ "pong") --- z2 <- 'yield' h (z1 ++ "dong") --- 'yield' h (z2 ++ "bong") --- mainThread h = do --- s1 <- 'yield' h "ping" --- s2 <- 'yield' h (s1 ++ "ding") --- s3 <- 'yield' h (s2 ++ "bing") --- pure s3 --- --- -- runPureEff pingpong == "pingpongdingdongbingbong" --- @ --- --- More than two coroutines may be interleaved. In the snippet below, four --- users pass a string to each other, extending it with breadcrumbs each time. --- --- For example, @userLL@ sends a string to @userLR@ (identified using the --- @Left (Right _)@ constructors in the 'yield' argument). When @userLL@ --- receives a second string @s'@ (from anywhere, in this case it will come from --- @userRR@), it forwards it to @userRL@. --- --- @ --- echo :: Eff ss String --- echo = 'loopCoPipe' ((userLL |+ userLR) |+ (userRL |+ userRR)) (Left (Left \"S\")) --- where --- userLL = 'toCoPipe' \\s h -> do --- s' <- 'yield' h (Left (Right (s ++ "-LL"))) -- send to userLR --- 'yield' h (Right (Left (s' ++ "-LL"))) -- send to userRL --- userLR = 'toCoPipe' \\s h -> do --- s' <- 'yield' h (Right (Left (s ++ "-LR"))) -- send to userRL --- 'yield' h (Right (Right (s' ++ "-LR"))) -- send to userRR --- userRL = 'toCoPipe' \\s h -> do --- s' <- 'yield' h (Right (Right (s ++ "-RL"))) -- send to userRR --- 'yield' h (Left (Right (s' ++ "-RL"))) -- send to userLR --- userRR = 'toCoPipe' \\s h -> do --- s' <- 'yield' h (Left (Left (s ++ "-RR"))) -- send to userLL --- pure (s' ++ "-RR") -- terminate --- (|+) = 'eitherCoPipe' id --- --- -- runPureEff echo == "S-LL-LR-RL-RR-LL-RL-LR-RR" --- @ --- --- == References --- --- Coroutines are also known as generators in Javascript and Python. --- --- - and --- --- on Wikipedia --- - --- - -module Bluefin.Algae.Coroutine - ( -- * Coroutines - - -- ** Operations - Coroutine(..) - , yield - - -- ** Handlers - , withCoroutine - , forCoroutine - - -- * Functions - , (:->) - , apply - , withFunction - - -- * Pipes - -- ** Definition - , Pipe(..) - , PipeEvent(..) - , CoPipe(..) - - -- ** Unwrap - , stepPipe - , applyCoPipe - , next - - -- ** Constructors - , simpleCoPipe - , voidCoPipe - , nothingPipe - , nothingCoPipe - - -- ** Pipe combinators - , mapPipe - , mapCoPipe - , eitherPipe - , eitherCoPipe - , openPipe - , openCoPipe - - -- ** Destructors - , runPipe - , runCoPipe - , forPipe - , forCoPipe - , loopPipe - , loopCoPipe - , feedPipe - , feedCoPipe - - -- ** Handlers involving pipes - - -- | Using the handlers 'toCoPipe' and 'toPipe' as primitives, - -- we can define the other handlers. - -- - -- @ - -- 'withCoroutine' g f = 'runPipe' ('toCoPipe' g) ('toPipe' f) - -- 'forCoroutine' g f = 'runPipe' ('simpleCoPipe' g) ('toPipe' f) - -- 'withCoPipe' g f = 'runPipe' g ('toPipe' f) - -- @ - , CoPipeSEff - , toCoPipe - , PipeSEff - , toPipe - , withCoPipe - - -- ** Interpreting pipes as coroutines - , CoPipeEff - , fromCoPipe - , PipeEff - , fromPipe - ) where - -import Data.Coerce (coerce) -import Data.Function (fix) -import Data.Functor ((<&>)) -import Data.Kind (Type) -import Data.Void (Void, absurd) -import Bluefin.Eff -import Bluefin.Algae - --- * Coroutines - --- | Coroutine effect with outputs @o@ and inputs @i@. -data Coroutine o i :: AEffect where - -- | Yield an output and wait for an input. - Yield :: o -> Coroutine o i i - --- | Call the 'Yield' operation. -yield :: z :> zz => Handler (Coroutine o i) z -> o -> Eff zz i -yield h o = call h (Yield o) - --- | This type synonym rebrands 'Coroutine' into a generic "function" effect, --- since without the concurrency connotations, the 'Yield' operation looks --- like a simple function call. -type (:->) :: Type -> Type -> AEffect -type (:->) = Coroutine - --- | Synonym for 'yield'. -apply :: z :> zz => Handler (a :-> b) z -> a -> Eff zz b -apply = yield - --- | Interpret @(':->')@ with a function. -withFunction :: forall a b r zz. - (a -> Eff zz b) -> - ScopedEff (a :-> b) zz r -> - Eff zz r -withFunction f g = forCoroutine g f --- This is morally @flip forCoroutine@ except that it wouldn't type check --- because 'forCoroutine' has a higher-rank type. - --- * Pipes - --- | Output-first coroutine. --- --- A 'Pipe' represents a coroutine as a state machine: --- a 'Pipe' yields an output @o@ and waits for an input @i@, or terminates with --- a result @a@. --- --- @ --- +--------------+ +----------------+ --- | 'Pipe' i o m a | ('Yielding' o)---> | 'CoPipe' i o m a | --- | | <------(input i) | | --- +--------------+ +----------------+ --- v ('Done') --- +---+ --- | a | --- +---+ --- @ -newtype Pipe i o m a = MkPipe (m (PipeEvent i o m a)) - --- | Events of 'Pipe'. -data PipeEvent i o m a - = Done a -- ^ Final result @a@ - | Yielding o (CoPipe i o m a) -- ^ Output @o@ and continue as 'CoPipe'. - --- | Input-first coroutine. 'Pipe' continuation. -newtype CoPipe i o m a - = MkCoPipe (i -> Pipe i o m a) -- ^ Input @i@ and continue as 'Pipe'. - --- | Unwrap 'Pipe'. -stepPipe :: Pipe i o m a -> m (PipeEvent i o m a) -stepPipe (MkPipe p) = p - --- | Unwrap 'CoPipe'. -applyCoPipe :: CoPipe i o m a -> i -> Pipe i o m a -applyCoPipe (MkCoPipe k) = k - --- | Apply a non-returning 'CoPipe' to yield the next output and 'CoPipe' state. -next :: Functor m => CoPipe i o m Void -> i -> m (o, CoPipe i o m Void) -next (MkCoPipe f) i = go <$> stepPipe (f i) where - go (Done v) = absurd v - go (Yielding o k) = (o, k) - --- | A 'CoPipe' which runs the same function on every input. -simpleCoPipe :: Functor m => (i -> m o) -> CoPipe i o m void -simpleCoPipe f = fix $ \self -> MkCoPipe (\i -> MkPipe ((\o -> Yielding o self) <$> f i)) - --- | Transform inputs and outputs of a 'Pipe'. -mapPipe :: Functor m => (i' -> i) -> (o -> o') -> (a -> a') -> Pipe i o m a -> Pipe i' o' m a' -mapPipe fi fo fa = mapPipe_ - where - mapPipe_ (MkPipe p) = MkPipe (loop <$> p) - loop (Done a) = Done (fa a) - loop (Yielding o k) = Yielding (fo o) (mapCoPipe_ k) - mapCoPipe_ (MkCoPipe k) = MkCoPipe (mapPipe_ . k . fi) - --- | Transform the input and output of a 'CoPipe'. -mapCoPipe :: Functor m => (i' -> i) -> (o -> o') -> (a -> a') -> CoPipe i o m a -> CoPipe i' o' m a' -mapCoPipe fi fo fa (MkCoPipe k) = MkCoPipe (mapPipe fi fo fa . k . fi) - --- | Run a 'Pipe' with a 'CoPipe' to respond to every output. -runPipe :: Monad m => CoPipe i o m Void -> Pipe o i m a -> m a -runPipe t (MkPipe p) = p >>= \e -> case e of - Done a -> pure a - Yielding i k -> do - (o, t') <- next t i - runCoPipe t' k o - --- | Run a 'CoPipe' with another 'CoPipe' to respond to every input. -runCoPipe :: Monad m => CoPipe i o m Void -> CoPipe o i m a -> o -> m a -runCoPipe t (MkCoPipe k) i = runPipe t (k i) - --- | Iterate through a 'Pipe'. Respond to every 'Yielding' event by running the loop body. --- Return the final result of the 'Pipe'. --- --- @ --- 'forPipe' p g = 'runPipe' ('simpleCoPipe' g) p --- @ -forPipe :: Monad m => - Pipe i o m a -> -- ^ Iterator - (o -> m i) -> -- ^ Loop body - m a -forPipe p h = stepPipe p >>= loop - where - loop (Done a) = pure a - loop (Yielding o k) = h o >>= \i -> stepPipe (applyCoPipe k i) >>= loop - --- | Iterate through a 'CoPipe'. -forCoPipe :: Monad m => - CoPipe i o m a -> - (o -> m i) -> - i -> m a -forCoPipe (MkCoPipe k) h i = forPipe (k i) h - --- | 'CoPipe' with no input. -voidCoPipe :: CoPipe Void o m a -voidCoPipe = MkCoPipe absurd - --- | Sum a copipe and a pipe with the same output type, --- branching on the input type. -eitherPipe :: Monad m => - (i -> Either i1 i2) -> -- ^ Dispatch input - CoPipe i1 o m a -> -- ^ Left copipe - Pipe i2 o m a -> -- ^ Right pipe - Pipe i o m a -eitherPipe split t0 (MkPipe p) = MkPipe $ p <&> \e -> case e of - Done a -> Done a - Yielding o k -> Yielding o (eitherCoPipe split t0 k) - --- | Sum two copipes with the same output type, branching on the input type. -eitherCoPipe :: Functor m => - (i -> Either i1 i2) -> -- ^ Dispatch input - CoPipe i1 o m a -> -- ^ Left copipe - CoPipe i2 o m a -> -- ^ Right copipe - CoPipe i o m a -eitherCoPipe split = loop - where - loop t1 t2 = MkCoPipe (MkPipe . transduce_ t1 t2 . split) - transduce_ (MkCoPipe t1) t2 (Left i1) = stepPipe (t1 i1) <&> \e -> case e of - Done a -> Done a - Yielding o t1' -> Yielding o (loop t1' t2) - transduce_ t1 (MkCoPipe t2) (Right i2) = stepPipe (t2 i2) <&> \e -> case e of - Done a -> Done a - Yielding o t2' -> Yielding o (loop t1 t2') - --- | Loop the output of a pipe back to its input. -loopPipe :: Monad m => Pipe o o m a -> m a -loopPipe (MkPipe p) = p >>= \e -> case e of - Done a -> pure a - Yielding o k -> loopCoPipe k o - --- | Forward the output of a 'CoPipe' to its input. -loopCoPipe :: Monad m => CoPipe o o m a -> o -> m a -loopCoPipe (MkCoPipe k) o = loopPipe (k o) - --- | Convert a returning 'Pipe' into a non-returning 'CoPipe', --- yielding 'Nothing' forever once the end has been reached. -openPipe :: Applicative m => Pipe i o m () -> Pipe i (Maybe o) m void -openPipe (MkPipe p) = MkPipe (p <&> \e -> case e of - Done _ -> Yielding Nothing nothingCoPipe - Yielding o k -> Yielding (Just o) (openCoPipe k)) - --- | Convert a returning 'CoPipe' into a non-returning 'CoPipe', --- yielding 'Nothing' forever once the end has been reached. -openCoPipe :: Applicative m => CoPipe i o m () -> CoPipe i (Maybe o) m void -openCoPipe (MkCoPipe k) = MkCoPipe (openPipe . k) - --- | Yield 'Nothing' forever. -nothingPipe :: Applicative m => Pipe i (Maybe o) m void -nothingPipe = MkPipe (pure (Yielding Nothing nothingCoPipe)) - --- | Yield 'Nothing' forever. -nothingCoPipe :: Applicative m => CoPipe i (Maybe o) m void -nothingCoPipe = MkCoPipe (\_ -> nothingPipe) - --- | Representation of 'Pipe' as scoped 'Eff' computations. -type PipeSEff i o zz a = ScopedEff (Coroutine o i) zz a - --- | Representation of 'Pipe' as 'Eff' computations. -type PipeEff i o zz a = forall z. z :> zz => Handler (Coroutine o i) z -> Eff zz a - --- | Representation of 'CoPipe' as scoped 'Eff' computations. -type CoPipeSEff i o zz a = i -> ScopedEff (Coroutine o i) zz a - --- | Representation of 'CoPipe' as 'Eff' computations. -type CoPipeEff i o zz a = forall z. z :> zz => i -> Handler (Coroutine o i) z -> Eff zz a - --- | Run a 'Pipe' with a fixed number of inputs. -feedPipe :: Monad m => [i] -> Pipe i o m a -> m [o] -feedPipe is (MkPipe m) = m >>= \e -> case e of - Done _ -> pure [] - Yielding o k -> (o :) <$> feedCoPipe is k - --- | Run a 'CoPipe' with a fixed number of inputs. -feedCoPipe :: Monad m => [i] -> CoPipe i o m a -> m [o] -feedCoPipe [] _ = pure [] -feedCoPipe (i : is) (MkCoPipe k) = feedPipe is (k i) - --- * Handlers - --- | Convert a coroutine that doesn't return into a 'CoPipe'. -toCoPipe :: forall o i a zz. - CoPipeSEff i o zz a -> CoPipe i o (Eff zz) a -toCoPipe f = MkCoPipe (\i -> toPipe (\h -> f i h)) - --- | Convert a 'CoPipe' into a coroutine. -fromCoPipe :: CoPipe i o (Eff zz) a -> CoPipeEff i o zz a -fromCoPipe (MkCoPipe k) i h = fromPipe (k i) h - --- | Evaluate a coroutine into a 'Pipe'. -toPipe :: forall o i a zz. - PipeSEff i o zz a -> - Pipe i o (Eff zz) a -toPipe f = MkPipe (handle coroutineHandler (wrap . f)) - where - coroutineHandler :: HandlerBody (Coroutine o i) zz (PipeEvent i o (Eff zz) a) - coroutineHandler (Yield o) k = pure (Yielding o (coerce k)) - - wrap :: Eff (z :& zz) a -> Eff (z :& zz) (PipeEvent i o (Eff zz) a) - wrap = fmap Done - --- | Convet a 'Pipe' into a coroutine. -fromPipe :: Pipe i o (Eff zz) a -> PipeEff i o zz a -fromPipe (MkPipe p) h = p >>= \e -> case e of - Done a -> pure a - Yielding o k -> yield h o >>= \i -> fromCoPipe k i h - --- | Interleave the execution of a copipe and a coroutine. -withCoPipe :: forall o i a zz. - CoPipe i o (Eff zz) a -> - ScopedEff (Coroutine i o) zz a -> -- ^ Starting coroutine - Eff zz a -withCoPipe g f = with g (handle coroutineHandler (fmap wrap . f)) - where - coroutineHandler :: HandlerBody (Coroutine i o) zz (CoPipe i o (Eff zz) a -> Eff zz a) - coroutineHandler (Yield o) k = pure $ \g1 -> do - stepPipe (applyCoPipe g1 o) >>= \e -> case e of - Done a -> pure a - Yielding i g2 -> with g2 (k i) - - wrap :: a -> z -> Eff zz a - wrap a _ = pure a - - with :: forall g. g -> Eff zz (g -> Eff zz a) -> Eff zz a - with g' m = m >>= \f' -> f' g' - --- | Interleave the execution of two coroutines, feeding each one's output to the other's input. --- Return the result of the first thread to terminate (the other is discarded) -withCoroutine :: forall o i a zz. - (i -> ScopedEff (Coroutine o i) zz a) -> - ScopedEff (Coroutine i o) zz a -> -- ^ Starting coroutine - Eff zz a -withCoroutine g f = withCoPipe (toCoPipe g) f - --- | Iterate through a coroutine: --- execute the loop body @o -> Eff zz i@ for every call to 'Yield' in the coroutine. -forCoroutine :: forall o i a zz. - ScopedEff (Coroutine o i) zz a -> -- ^ Iterator - (o -> Eff zz i) -> -- ^ Loop body - Eff zz a -forCoroutine f h = handle coroutineHandler f - where - coroutineHandler :: HandlerBody (Coroutine o i) zz a - coroutineHandler (Yield o) k = h o >>= k +{-# LANGUAGE + BangPatterns, + DataKinds, + GADTs, + KindSignatures, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | = Coroutines: yield as an algebraic effect +-- +-- == Iterators +-- +-- A simple use case of coroutines is as an expressive way of defining iterators. +-- +-- An iterator is just a program which yields values. The following example +-- yields the integers 1, 2, 3, 4. +-- +-- @ +-- range1to4 :: z :> zz => Handler (Coroutine Int ()) z -> Eff zz () +-- range1to4 h = do +-- 'yield' h 1 +-- 'yield' h 2 +-- 'yield' h 3 +-- 'yield' h 4 +-- @ +-- +-- The 'forCoroutine' handler is a "for" loop over an iterator, +-- running the loop body for every yielded element. +-- Here we collect the even values into a list stored in mutable @State@. +-- +-- @ +-- filterEven :: z :> zz => Handler (State [Int]) z -> Eff zz () +-- filterEven h = +-- 'forCoroutine' range1to4 \\n -> +-- if n \`mod\` 2 == 0 +-- then modify h (n :) +-- else pure () +-- +-- filterEvenResult :: [Int] +-- filterEvenResult = runPureEff $ execState [] filterEven +-- +-- -- 1 and 3 are filtered out, 2 and 4 are pushed into the queue +-- in that order, so they appear in reverse order. +-- -- filterEvenResult == [4,2] +-- @ +-- +-- == Cooperative concurrency +-- +-- Coroutines are "cooperative threads", passing control to other coroutines +-- with explicit 'yield' calls. +-- +-- In the following example, two threads yield a string back and forth, +-- appending a suffix every time. +-- +-- @ +-- pingpong :: Eff ss String +-- pingpong = 'withCoroutine' coThread mainThread +-- where +-- coThread z0 h = do +-- z1 <- 'yield' h (z0 ++ "pong") +-- z2 <- 'yield' h (z1 ++ "dong") +-- 'yield' h (z2 ++ "bong") +-- mainThread h = do +-- s1 <- 'yield' h "ping" +-- s2 <- 'yield' h (s1 ++ "ding") +-- s3 <- 'yield' h (s2 ++ "bing") +-- pure s3 +-- +-- -- runPureEff pingpong == "pingpongdingdongbingbong" +-- @ +-- +-- More than two coroutines may be interleaved. In the snippet below, four +-- users pass a string to each other, extending it with breadcrumbs each time. +-- +-- For example, @userLL@ sends a string to @userLR@ (identified using the +-- @Left (Right _)@ constructors in the 'yield' argument). When @userLL@ +-- receives a second string @s'@ (from anywhere, in this case it will come from +-- @userRR@), it forwards it to @userRL@. +-- +-- @ +-- echo :: Eff ss String +-- echo = 'loopCoPipe' ((userLL |+ userLR) |+ (userRL |+ userRR)) (Left (Left \"S\")) +-- where +-- userLL = 'toCoPipe' \\s h -> do +-- s' <- 'yield' h (Left (Right (s ++ "-LL"))) -- send to userLR +-- 'yield' h (Right (Left (s' ++ "-LL"))) -- send to userRL +-- userLR = 'toCoPipe' \\s h -> do +-- s' <- 'yield' h (Right (Left (s ++ "-LR"))) -- send to userRL +-- 'yield' h (Right (Right (s' ++ "-LR"))) -- send to userRR +-- userRL = 'toCoPipe' \\s h -> do +-- s' <- 'yield' h (Right (Right (s ++ "-RL"))) -- send to userRR +-- 'yield' h (Left (Right (s' ++ "-RL"))) -- send to userLR +-- userRR = 'toCoPipe' \\s h -> do +-- s' <- 'yield' h (Left (Left (s ++ "-RR"))) -- send to userLL +-- pure (s' ++ "-RR") -- terminate +-- (|+) = 'eitherCoPipe' id +-- +-- -- runPureEff echo == "S-LL-LR-RL-RR-LL-RL-LR-RR" +-- @ +-- +-- == References +-- +-- Coroutines are also known as generators in Javascript and Python. +-- +-- - and +-- +-- on Wikipedia +-- - +-- - +module Bluefin.Algae.Coroutine + ( -- * Coroutines + + -- ** Operations + Coroutine(..) + , yield + + -- ** Handlers + , withCoroutine + , forCoroutine + + -- * Functions + , (:->) + , apply + , withFunction + + -- * Pipes + -- ** Definition + , Pipe(..) + , PipeEvent(..) + , CoPipe(..) + + -- ** Unwrap + , stepPipe + , applyCoPipe + , next + + -- ** Constructors + , simpleCoPipe + , voidCoPipe + , nothingPipe + , nothingCoPipe + + -- ** Pipe combinators + , mapPipe + , mapCoPipe + , eitherPipe + , eitherCoPipe + , openPipe + , openCoPipe + + -- ** Destructors + , runPipe + , runCoPipe + , forPipe + , forCoPipe + , loopPipe + , loopCoPipe + , feedPipe + , feedCoPipe + + -- ** Handlers involving pipes + + -- | Using the handlers 'toCoPipe' and 'toPipe' as primitives, + -- we can define the other handlers. + -- + -- @ + -- 'withCoroutine' g f = 'runPipe' ('toCoPipe' g) ('toPipe' f) + -- 'forCoroutine' g f = 'runPipe' ('simpleCoPipe' g) ('toPipe' f) + -- 'withCoPipe' g f = 'runPipe' g ('toPipe' f) + -- @ + , CoPipeSEff + , toCoPipe + , PipeSEff + , toPipe + , withCoPipe + + -- ** Interpreting pipes as coroutines + , CoPipeEff + , fromCoPipe + , PipeEff + , fromPipe + ) where + +import Data.Coerce (coerce) +import Data.Function (fix) +import Data.Functor ((<&>)) +import Data.Kind (Type) +import Data.Void (Void, absurd) +import Bluefin.Eff +import Bluefin.Algae + +-- * Coroutines + +-- | Coroutine effect with outputs @o@ and inputs @i@. +data Coroutine o i :: AEffect where + -- | Yield an output and wait for an input. + Yield :: o -> Coroutine o i i + +-- | Call the 'Yield' operation. +yield :: z :> zz => Handler (Coroutine o i) z -> o -> Eff zz i +yield h o = call h (Yield o) + +-- | This type synonym rebrands 'Coroutine' into a generic "function" effect, +-- since without the concurrency connotations, the 'Yield' operation looks +-- like a simple function call. +type (:->) :: Type -> Type -> AEffect +type (:->) = Coroutine + +-- | Synonym for 'yield'. +apply :: z :> zz => Handler (a :-> b) z -> a -> Eff zz b +apply = yield + +-- | Interpret @(':->')@ with a function. +withFunction :: forall a b r zz. + (a -> Eff zz b) -> + ScopedEff (a :-> b) zz r -> + Eff zz r +withFunction f g = forCoroutine g f +-- This is morally @flip forCoroutine@ except that it wouldn't type check +-- because 'forCoroutine' has a higher-rank type. + +-- * Pipes + +-- | Output-first coroutine. +-- +-- A 'Pipe' represents a coroutine as a state machine: +-- a 'Pipe' yields an output @o@ and waits for an input @i@, or terminates with +-- a result @a@. +-- +-- @ +-- +--------------+ +----------------+ +-- | 'Pipe' i o m a | ('Yielding' o)---> | 'CoPipe' i o m a | +-- | | <------(input i) | | +-- +--------------+ +----------------+ +-- v ('Done') +-- +---+ +-- | a | +-- +---+ +-- @ +newtype Pipe i o m a = MkPipe (m (PipeEvent i o m a)) + +-- | Events of 'Pipe'. +data PipeEvent i o m a + = Done a -- ^ Final result @a@ + | Yielding o (CoPipe i o m a) -- ^ Output @o@ and continue as 'CoPipe'. + +-- | Input-first coroutine. 'Pipe' continuation. +newtype CoPipe i o m a + = MkCoPipe (i -> Pipe i o m a) -- ^ Input @i@ and continue as 'Pipe'. + +-- | Unwrap 'Pipe'. +stepPipe :: Pipe i o m a -> m (PipeEvent i o m a) +stepPipe (MkPipe p) = p + +-- | Unwrap 'CoPipe'. +applyCoPipe :: CoPipe i o m a -> i -> Pipe i o m a +applyCoPipe (MkCoPipe k) = k + +-- | Apply a non-returning 'CoPipe' to yield the next output and 'CoPipe' state. +next :: Functor m => CoPipe i o m Void -> i -> m (o, CoPipe i o m Void) +next (MkCoPipe f) i = go <$> stepPipe (f i) where + go (Done v) = absurd v + go (Yielding o k) = (o, k) + +-- | A 'CoPipe' which runs the same function on every input. +simpleCoPipe :: Functor m => (i -> m o) -> CoPipe i o m void +simpleCoPipe f = fix $ \self -> MkCoPipe (\i -> MkPipe ((\o -> Yielding o self) <$> f i)) + +-- | Transform inputs and outputs of a 'Pipe'. +mapPipe :: Functor m => (i' -> i) -> (o -> o') -> (a -> a') -> Pipe i o m a -> Pipe i' o' m a' +mapPipe fi fo fa = mapPipe_ + where + mapPipe_ (MkPipe p) = MkPipe (loop <$> p) + loop (Done a) = Done (fa a) + loop (Yielding o k) = Yielding (fo o) (mapCoPipe_ k) + mapCoPipe_ (MkCoPipe k) = MkCoPipe (mapPipe_ . k . fi) + +-- | Transform the input and output of a 'CoPipe'. +mapCoPipe :: Functor m => (i' -> i) -> (o -> o') -> (a -> a') -> CoPipe i o m a -> CoPipe i' o' m a' +mapCoPipe fi fo fa (MkCoPipe k) = MkCoPipe (mapPipe fi fo fa . k . fi) + +-- | Run a 'Pipe' with a 'CoPipe' to respond to every output. +runPipe :: Monad m => CoPipe i o m Void -> Pipe o i m a -> m a +runPipe t (MkPipe p) = p >>= \e -> case e of + Done a -> pure a + Yielding i k -> do + (o, t') <- next t i + runCoPipe t' k o + +-- | Run a 'CoPipe' with another 'CoPipe' to respond to every input. +runCoPipe :: Monad m => CoPipe i o m Void -> CoPipe o i m a -> o -> m a +runCoPipe t (MkCoPipe k) i = runPipe t (k i) + +-- | Iterate through a 'Pipe'. Respond to every 'Yielding' event by running the loop body. +-- Return the final result of the 'Pipe'. +-- +-- @ +-- 'forPipe' p g = 'runPipe' ('simpleCoPipe' g) p +-- @ +forPipe :: Monad m => + Pipe i o m a -> -- ^ Iterator + (o -> m i) -> -- ^ Loop body + m a +forPipe p h = stepPipe p >>= loop + where + loop (Done a) = pure a + loop (Yielding o k) = h o >>= \i -> stepPipe (applyCoPipe k i) >>= loop + +-- | Iterate through a 'CoPipe'. +forCoPipe :: Monad m => + CoPipe i o m a -> + (o -> m i) -> + i -> m a +forCoPipe (MkCoPipe k) h i = forPipe (k i) h + +-- | 'CoPipe' with no input. +voidCoPipe :: CoPipe Void o m a +voidCoPipe = MkCoPipe absurd + +-- | Sum a copipe and a pipe with the same output type, +-- branching on the input type. +eitherPipe :: Monad m => + (i -> Either i1 i2) -> -- ^ Dispatch input + CoPipe i1 o m a -> -- ^ Left copipe + Pipe i2 o m a -> -- ^ Right pipe + Pipe i o m a +eitherPipe split t0 (MkPipe p) = MkPipe $ p <&> \e -> case e of + Done a -> Done a + Yielding o k -> Yielding o (eitherCoPipe split t0 k) + +-- | Sum two copipes with the same output type, branching on the input type. +eitherCoPipe :: Functor m => + (i -> Either i1 i2) -> -- ^ Dispatch input + CoPipe i1 o m a -> -- ^ Left copipe + CoPipe i2 o m a -> -- ^ Right copipe + CoPipe i o m a +eitherCoPipe split = loop + where + loop t1 t2 = MkCoPipe (MkPipe . transduce_ t1 t2 . split) + transduce_ (MkCoPipe t1) t2 (Left i1) = stepPipe (t1 i1) <&> \e -> case e of + Done a -> Done a + Yielding o t1' -> Yielding o (loop t1' t2) + transduce_ t1 (MkCoPipe t2) (Right i2) = stepPipe (t2 i2) <&> \e -> case e of + Done a -> Done a + Yielding o t2' -> Yielding o (loop t1 t2') + +-- | Loop the output of a pipe back to its input. +loopPipe :: Monad m => Pipe o o m a -> m a +loopPipe (MkPipe p) = p >>= \e -> case e of + Done a -> pure a + Yielding o k -> loopCoPipe k o + +-- | Forward the output of a 'CoPipe' to its input. +loopCoPipe :: Monad m => CoPipe o o m a -> o -> m a +loopCoPipe (MkCoPipe k) o = loopPipe (k o) + +-- | Convert a returning 'Pipe' into a non-returning 'CoPipe', +-- yielding 'Nothing' forever once the end has been reached. +openPipe :: Applicative m => Pipe i o m () -> Pipe i (Maybe o) m void +openPipe (MkPipe p) = MkPipe (p <&> \e -> case e of + Done _ -> Yielding Nothing nothingCoPipe + Yielding o k -> Yielding (Just o) (openCoPipe k)) + +-- | Convert a returning 'CoPipe' into a non-returning 'CoPipe', +-- yielding 'Nothing' forever once the end has been reached. +openCoPipe :: Applicative m => CoPipe i o m () -> CoPipe i (Maybe o) m void +openCoPipe (MkCoPipe k) = MkCoPipe (openPipe . k) + +-- | Yield 'Nothing' forever. +nothingPipe :: Applicative m => Pipe i (Maybe o) m void +nothingPipe = MkPipe (pure (Yielding Nothing nothingCoPipe)) + +-- | Yield 'Nothing' forever. +nothingCoPipe :: Applicative m => CoPipe i (Maybe o) m void +nothingCoPipe = MkCoPipe (\_ -> nothingPipe) + +-- | Representation of 'Pipe' as scoped 'Eff' computations. +type PipeSEff i o zz a = ScopedEff (Coroutine o i) zz a + +-- | Representation of 'Pipe' as 'Eff' computations. +type PipeEff i o zz a = forall z. z :> zz => Handler (Coroutine o i) z -> Eff zz a + +-- | Representation of 'CoPipe' as scoped 'Eff' computations. +type CoPipeSEff i o zz a = i -> ScopedEff (Coroutine o i) zz a + +-- | Representation of 'CoPipe' as 'Eff' computations. +type CoPipeEff i o zz a = forall z. z :> zz => i -> Handler (Coroutine o i) z -> Eff zz a + +-- | Run a 'Pipe' with a fixed number of inputs. +feedPipe :: Monad m => [i] -> Pipe i o m a -> m [o] +feedPipe is (MkPipe m) = m >>= \e -> case e of + Done _ -> pure [] + Yielding o k -> (o :) <$> feedCoPipe is k + +-- | Run a 'CoPipe' with a fixed number of inputs. +feedCoPipe :: Monad m => [i] -> CoPipe i o m a -> m [o] +feedCoPipe [] _ = pure [] +feedCoPipe (i : is) (MkCoPipe k) = feedPipe is (k i) + +-- * Handlers + +-- | Convert a coroutine that doesn't return into a 'CoPipe'. +toCoPipe :: forall o i a zz. + CoPipeSEff i o zz a -> CoPipe i o (Eff zz) a +toCoPipe f = MkCoPipe (\i -> toPipe (\h -> f i h)) + +-- | Convert a 'CoPipe' into a coroutine. +fromCoPipe :: CoPipe i o (Eff zz) a -> CoPipeEff i o zz a +fromCoPipe (MkCoPipe k) i h = fromPipe (k i) h + +-- | Evaluate a coroutine into a 'Pipe'. +toPipe :: forall o i a zz. + PipeSEff i o zz a -> + Pipe i o (Eff zz) a +toPipe f = MkPipe (handle coroutineHandler (wrap . f)) + where + coroutineHandler :: HandlerBody (Coroutine o i) zz (PipeEvent i o (Eff zz) a) + coroutineHandler (Yield o) k = pure (Yielding o (coerce k)) + + wrap :: Eff (z :& zz) a -> Eff (z :& zz) (PipeEvent i o (Eff zz) a) + wrap = fmap Done + +-- | Convet a 'Pipe' into a coroutine. +fromPipe :: Pipe i o (Eff zz) a -> PipeEff i o zz a +fromPipe (MkPipe p) h = p >>= \e -> case e of + Done a -> pure a + Yielding o k -> yield h o >>= \i -> fromCoPipe k i h + +-- | Interleave the execution of a copipe and a coroutine. +withCoPipe :: forall o i a zz. + CoPipe i o (Eff zz) a -> + ScopedEff (Coroutine i o) zz a -> -- ^ Starting coroutine + Eff zz a +withCoPipe g f = with g (handle coroutineHandler (fmap wrap . f)) + where + coroutineHandler :: HandlerBody (Coroutine i o) zz (CoPipe i o (Eff zz) a -> Eff zz a) + coroutineHandler (Yield o) k = pure $ \g1 -> do + stepPipe (applyCoPipe g1 o) >>= \e -> case e of + Done a -> pure a + Yielding i g2 -> with g2 (k i) + + wrap :: a -> z -> Eff zz a + wrap a _ = pure a + + with :: forall g. g -> Eff zz (g -> Eff zz a) -> Eff zz a + with g' m = m >>= \f' -> f' g' + +-- | Interleave the execution of two coroutines, feeding each one's output to the other's input. +-- Return the result of the first thread to terminate (the other is discarded) +withCoroutine :: forall o i a zz. + (i -> ScopedEff (Coroutine o i) zz a) -> + ScopedEff (Coroutine i o) zz a -> -- ^ Starting coroutine + Eff zz a +withCoroutine g f = withCoPipe (toCoPipe g) f + +-- | Iterate through a coroutine: +-- execute the loop body @o -> Eff zz i@ for every call to 'Yield' in the coroutine. +forCoroutine :: forall o i a zz. + ScopedEff (Coroutine o i) zz a -> -- ^ Iterator + (o -> Eff zz i) -> -- ^ Loop body + Eff zz a +forCoroutine f h = handle coroutineHandler f + where + coroutineHandler :: HandlerBody (Coroutine o i) zz a + coroutineHandler (Yield o) k = h o >>= k diff --git a/src/Bluefin/Algae/DelCont.hs b/src/Bluefin/Algae/DelCont.hs --- a/src/Bluefin/Algae/DelCont.hs +++ b/src/Bluefin/Algae/DelCont.hs @@ -1,186 +1,187 @@ -{-# LANGUAGE - BangPatterns, - MagicHash, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators, - UnboxedTuples #-} - --- | = Delimited continuations --- --- Native multi-prompt delimited continuations. --- These primitives let us manipulate slices of the call stack/evaluation --- context delimited by 'reset'. --- --- This module serves as a foundation for algebraic effect handlers, --- a more structured interface for manipulating continuations and implementing --- user-defined effects. --- --- The behavior of 'reset' and 'shift0' is summarized by the following equations: --- --- @ --- 'reset' (\\_ -> 'pure' x) = 'pure' x --- 'reset' (\\t -> C ('shift0' t f)) = f (\\x -> 'reset' (\\t -> C x)) --- @ --- --- where @C@ is an evaluation context (in which @t@ may occur), i.e., --- a term of the following form: --- --- > C x ::= C x >>= k -- for any function k --- > | H (\h -> C x) -- for any handler H ∈ { reset, (`runState` s), ... } --- > | x --- --- --- This module ensures type safety. The rank-2 type of 'reset' --- guarantees that 'shift0' will always have a maching 'reset' on the stack. --- --- === References --- --- - (GHC proposal, implemented in GHC 9.6.1). --- - (2004) by Chung-chieh Shan. The name 'shift0' follows the nomenclature in that paper. -module Bluefin.Algae.DelCont - ( PromptTag - , reset - , shift0 - , Continuation - , weakenC1 - , resume - , continue - , cancel - ) where - -import Data.Coerce (coerce) -import Data.Functor (void) -import Data.Kind (Type) -import GHC.Exts (State#, RealWorld, PromptTag#, prompt#, control0#, newPromptTag#) -import GHC.IO (IO(IO)) -import Bluefin.Internal (Eff(UnsafeMkEff)) -import Bluefin.Eff -import qualified Bluefin.Exception as E - --- | Tag for a prompt of type @Eff ss a@ and scope @s@. -type PromptTag :: Effects -> Type -> Effects -> Type -data PromptTag ss a s = MkPromptTag (PromptTag# a) - --- | Run the enclosed computation under a prompt of type @Eff ss a@. --- --- @ --- f : forall s. 'PromptTag' ss a s -> 'Eff' (s ':&' ss) a --- ------------------------------------------------- --- 'reset' (\\t -> f t) : 'Eff' ss a --- @ --- --- The enclosed computation @f@ is given a tag which identifies that prompt --- and remembers its type. --- The scope parameter @s@ prevents the tag from being used outside of the --- computation. --- --- A prompt ('reset') delimits a slice of the call stack (or evaluation context), --- which can be captured with 'shift0'. This slice, a continuation, --- becomes a function of type @Eff ss0 b -> Eff ss a@ (where @Eff ss0 b@ is the --- result type of 'shift0' at its calling site). --- Calling the continuation restores the slice on the stack. -reset :: forall a ss. - (forall s. PromptTag ss a s -> Eff (s :& ss) a) -> - Eff ss a -reset f = unsafeMkEff (\z0 -> case newPromptTag# z0 of - (# z1, tag #) -> prompt# tag (unsafeRunEff (f (MkPromptTag tag))) z1) - --- | Continuations are slices of the call stack, or evaluation context. --- --- The 'Continuation' type is abstract since not all functions @'Eff' t b -> 'Eff' s a@ --- represent evaluation contexts. In particular, 'weakenC1' is not definable for arbitrary --- such functions. --- --- For example, in --- --- @ --- reset \\tag0 -> --- reset \\tag1 -> --- reset \\tag2 -> --- shift0 tag1 f >>= etc --- @ --- --- 'shift0' captures a continuation, the slice represented by the following --- function: --- --- @ --- MkContinuation \\hole -> --- reset \\tag1 -> --- reset \\tag2 -> --- hole >>= etc --- @ --- --- That continuation has type @'Continuation' t s b a@ where @Eff t b@ is the type of the hole, --- and @Eff s a@ is the type of the result once the hole is plugged. --- --- The second argument of 'shift0', @f@, is applied to the continuation: --- --- @ --- reset \\tag0 -> --- f (MkContinuation \\hole -> --- reset \\tag1 -> --- reset \\tag2 -> --- hole >>= etc) --- @ -newtype Continuation t s b a = MkContinuation (Eff t b -> Eff s a) - --- | Extend the context of a continuation. -weakenC1 :: Continuation t s b a -> Continuation (e :& t) (e :& s) b a -weakenC1 = coerce - --- | Resume a continuation with a computation under it. -resume :: Continuation t s b a -> Eff t b -> Eff s a -resume (MkContinuation k) = k - --- | Resume a cancellable continuation with a result. --- --- In other words, this converts a cancellable continuation to a simple continuation. -continue :: Continuation t s b a -> b -> Eff s a -continue k = resume k . pure - --- | Cancel a continuation: resume by throwing a scoped exception and catch it. --- --- The continuation SHOULD re-throw unknown exceptions. --- (That is guaranteed if you don't use "Exception.Dynamic".) -cancel :: Continuation t s b a -> Eff s () -cancel k = E.catch (\ex -> void (resume (weakenC1 k) (E.throw ex ()))) (\_ -> pure ()) - --- | Capture the continuation up to the tagged prompt. --- --- @ --- _ : s :> ss0 --- t : 'PromptTag' ss a s --- f : ('Eff' ss0 b -> 'Eff' ss a) -> 'Eff' ss a --- --------------------------------------- --- 'shift0' t (\\k -> f k) : 'Eff' ss0 b --- @ --- --- The prompt ('reset') is reinserted on the stack when the continuation is called: --- --- @ --- 'reset' (\\t -> C ('shift0' t f)) = f (\\x -> 'reset' (\\t -> C x)) --- @ -shift0 :: forall s a b ss ss0. - s :> ss0 => - PromptTag ss a s -> - (Continuation ss0 ss b a -> Eff ss a) -> - Eff ss0 b -shift0 (MkPromptTag tag) f = unsafeMkEff (\z0 -> - control0# tag (\k# -> - unsafeRunEff (f (unsafeContinuation# (prompt# tag . k#)))) z0) - --- * Internal - -type IO# a = State# RealWorld -> (# State# RealWorld , a #) -type Continuation# a b = IO# a -> IO# b - -unsafeMkEff :: IO# a -> Eff ss a -unsafeMkEff f = UnsafeMkEff (IO f) - -unsafeRunEff :: Eff ss a -> IO# a -unsafeRunEff (UnsafeMkEff (IO f)) = f - -unsafeContinuation# :: Continuation# b a -> Continuation t s b a -unsafeContinuation# k = MkContinuation (unsafeMkEff . k . unsafeRunEff) +{-# LANGUAGE + BangPatterns, + DataKinds, + MagicHash, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators, + UnboxedTuples #-} + +-- | = Delimited continuations +-- +-- Native multi-prompt delimited continuations. +-- These primitives let us manipulate slices of the call stack/evaluation +-- context delimited by 'reset'. +-- +-- This module serves as a foundation for algebraic effect handlers, +-- a more structured interface for manipulating continuations and implementing +-- user-defined effects. +-- +-- The behavior of 'reset' and 'shift0' is summarized by the following equations: +-- +-- @ +-- 'reset' (\\_ -> 'pure' x) = 'pure' x +-- 'reset' (\\t -> C ('shift0' t f)) = f (\\x -> 'reset' (\\t -> C x)) +-- @ +-- +-- where @C@ is an evaluation context (in which @t@ may occur), i.e., +-- a term of the following form: +-- +-- > C x ::= C x >>= k -- for any function k +-- > | H (\h -> C x) -- for any handler H ∈ { reset, (`runState` s), ... } +-- > | x +-- +-- +-- This module ensures type safety. The rank-2 type of 'reset' +-- guarantees that 'shift0' will always have a maching 'reset' on the stack. +-- +-- === References +-- +-- - (GHC proposal, implemented in GHC 9.6.1). +-- - (2004) by Chung-chieh Shan. The name 'shift0' follows the nomenclature in that paper. +module Bluefin.Algae.DelCont + ( PromptTag + , reset + , shift0 + , Continuation + , weakenC1 + , resume + , continue + , cancel + ) where + +import Data.Coerce (coerce) +import Data.Functor (void) +import Data.Kind (Type) +import GHC.Exts (State#, RealWorld, PromptTag#, prompt#, control0#, newPromptTag#) +import GHC.IO (IO(IO)) +import Bluefin.Internal (Eff(UnsafeMkEff)) +import Bluefin.Eff +import qualified Bluefin.Exception as E + +-- | Tag for a prompt of type @Eff ss a@ and scope @s@. +type PromptTag :: Effects -> Type -> Effects -> Type +data PromptTag ss a s = MkPromptTag (PromptTag# a) + +-- | Run the enclosed computation under a prompt of type @Eff ss a@. +-- +-- @ +-- f : forall s. 'PromptTag' ss a s -> 'Eff' (s ':&' ss) a +-- ------------------------------------------------- +-- 'reset' (\\t -> f t) : 'Eff' ss a +-- @ +-- +-- The enclosed computation @f@ is given a tag which identifies that prompt +-- and remembers its type. +-- The scope parameter @s@ prevents the tag from being used outside of the +-- computation. +-- +-- A prompt ('reset') delimits a slice of the call stack (or evaluation context), +-- which can be captured with 'shift0'. This slice, a continuation, +-- becomes a function of type @Eff ss0 b -> Eff ss a@ (where @Eff ss0 b@ is the +-- result type of 'shift0' at its calling site). +-- Calling the continuation restores the slice on the stack. +reset :: forall a ss. + (forall s. PromptTag ss a s -> Eff (s :& ss) a) -> + Eff ss a +reset f = unsafeMkEff (\z0 -> case newPromptTag# z0 of + (# z1, tag #) -> prompt# tag (unsafeRunEff (f (MkPromptTag tag))) z1) + +-- | Continuations are slices of the call stack, or evaluation context. +-- +-- The 'Continuation' type is abstract since not all functions @'Eff' t b -> 'Eff' s a@ +-- represent evaluation contexts. In particular, 'weakenC1' is not definable for arbitrary +-- such functions. +-- +-- For example, in +-- +-- @ +-- reset \\tag0 -> +-- reset \\tag1 -> +-- reset \\tag2 -> +-- shift0 tag1 f >>= etc +-- @ +-- +-- 'shift0' captures a continuation, the slice represented by the following +-- function: +-- +-- @ +-- MkContinuation \\hole -> +-- reset \\tag1 -> +-- reset \\tag2 -> +-- hole >>= etc +-- @ +-- +-- That continuation has type @'Continuation' t s b a@ where @Eff t b@ is the type of the hole, +-- and @Eff s a@ is the type of the result once the hole is plugged. +-- +-- The second argument of 'shift0', @f@, is applied to the continuation: +-- +-- @ +-- reset \\tag0 -> +-- f (MkContinuation \\hole -> +-- reset \\tag1 -> +-- reset \\tag2 -> +-- hole >>= etc) +-- @ +newtype Continuation t s b a = MkContinuation (Eff t b -> Eff s a) + +-- | Extend the context of a continuation. +weakenC1 :: Continuation t s b a -> Continuation (e :& t) (e :& s) b a +weakenC1 = coerce + +-- | Resume a continuation with a computation under it. +resume :: Continuation t s b a -> Eff t b -> Eff s a +resume (MkContinuation k) = k + +-- | Resume a cancellable continuation with a result. +-- +-- In other words, this converts a cancellable continuation to a simple continuation. +continue :: Continuation t s b a -> b -> Eff s a +continue k = resume k . pure + +-- | Cancel a continuation: resume by throwing a scoped exception and catch it. +-- +-- The continuation SHOULD re-throw unknown exceptions. +-- (That is guaranteed if you don't use "Exception.Dynamic".) +cancel :: Continuation t s b a -> Eff s () +cancel k = E.catch (\ex -> void (resume (weakenC1 k) (E.throw ex ()))) (\_ -> pure ()) + +-- | Capture the continuation up to the tagged prompt. +-- +-- @ +-- _ : s :> ss0 +-- t : 'PromptTag' ss a s +-- f : ('Eff' ss0 b -> 'Eff' ss a) -> 'Eff' ss a +-- --------------------------------------- +-- 'shift0' t (\\k -> f k) : 'Eff' ss0 b +-- @ +-- +-- The prompt ('reset') is reinserted on the stack when the continuation is called: +-- +-- @ +-- 'reset' (\\t -> C ('shift0' t f)) = f (\\x -> 'reset' (\\t -> C x)) +-- @ +shift0 :: forall s a b ss ss0. + s :> ss0 => + PromptTag ss a s -> + (Continuation ss0 ss b a -> Eff ss a) -> + Eff ss0 b +shift0 (MkPromptTag tag) f = unsafeMkEff (\z0 -> + control0# tag (\k# -> + unsafeRunEff (f (unsafeContinuation# (prompt# tag . k#)))) z0) + +-- * Internal + +type IO# a = State# RealWorld -> (# State# RealWorld , a #) +type Continuation# a b = IO# a -> IO# b + +unsafeMkEff :: IO# a -> Eff ss a +unsafeMkEff f = UnsafeMkEff (IO f) + +unsafeRunEff :: Eff ss a -> IO# a +unsafeRunEff (UnsafeMkEff (IO f)) = f + +unsafeContinuation# :: Continuation# b a -> Continuation t s b a +unsafeContinuation# k = MkContinuation (unsafeMkEff . k . unsafeRunEff) diff --git a/src/Bluefin/Algae/DynExn.hs b/src/Bluefin/Algae/DynExn.hs --- a/src/Bluefin/Algae/DynExn.hs +++ b/src/Bluefin/Algae/DynExn.hs @@ -1,86 +1,87 @@ -{-# LANGUAGE - BangPatterns, - DeriveAnyClass, - GADTs, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | = Algebraic effects and named handlers --- --- Variant of "Bluefin.Algae" using dynamic exceptions to cancel continuations. -module Bluefin.Algae.DynExn - ( AEffect - , HandlerBody - , Handler - , handle - , call - , continue - , discontinue - , discontinueIO - , cancel - , CancelContinuation(..) - ) where - -import Control.Exception (Exception) -import Data.Kind (Type) -import Data.Functor (void) -import Bluefin.Internal (Eff, Effects, type (:&), type (:>), IOE) -import Bluefin.Algae.DelCont (PromptTag, Continuation, reset, shift0, resume, continue) -import Bluefin.Exception.Dynamic -import Bluefin.Algae (AEffect) - --- | Interpretation of an algebraic effect @f@: a function to handle the operations of @f@ --- with cancellable continuations. -type HandlerBody :: Effects -> AEffect -> Effects -> Type -> Type -type HandlerBody ex f ss a = (forall x ss0. ex :> ss0 => f x -> Continuation ss0 ss x a -> Eff ss a) - --- | Handler to call operations of the effect @f@ with cancellable continuations. -type Handler :: Effects -> AEffect -> Effects -> Type -data Handler ex f s where - MkHandler :: !(PromptTag ss a s) -> HandlerBody ex f ss a -> Handler ex f s - --- | Handle operations of @f@ with cancellable continuations. --- --- The handle for exceptions (first argument) is only there to guide type inference. --- it can be either 'IOE' or 'DynExn'. -handle :: - h ex -> - HandlerBody ex f ss a -> - (forall s. Handler ex f s -> Eff (s :& ss) a) -> - Eff ss a -handle _ h act = reset (\p -> act (MkHandler p h)) - --- | Call an operation of @f@ with cancellable continuations. -call :: (ex :> es, s :> es) => Handler ex f s -> f a -> Eff es a -call (MkHandler p h) op = shift0 p (\k -> h op k) - --- | Resume by throwing a dynamic exception. --- --- Note that different outcomes are possible depending on your handled computation. --- Be sure to handle them appropriately. --- --- - A common situation is that the continuation will rethrow the initial exception, --- then you can just catch it (or use 'cancel'). --- - The continuation may throw a different exception, so you should be --- careful to catch the right exception. --- - The continuation may also catch your exception and terminate normally --- with a result of type @a@. -discontinue :: (Exception e, ex :> es0) => DynExn ex -> Continuation es0 es b a -> e -> Eff es a -discontinue ex k e = resume k (throw ex e) - --- | Specialization of 'discontinue' to 'IOE'. -discontinueIO :: (Exception e, io :> es0) => IOE io -> Continuation es0 es b a -> e -> Eff es a -discontinueIO io = discontinue (ioeToDynExn io) - --- | 'discontinue' a continuation with the v'CancelContinuation' exception and catch it when it --- is re-thrown by the continuation. --- --- The continuation SHOULD re-throw v'CancelContinuation' if it catches it. -cancel :: (ex :> es0, ex :> es) => DynExn ex -> Continuation es0 es b a -> Eff es () -cancel ex k = catch ex (void (discontinue ex k CancelContinuation)) (\CancelContinuation -> pure ()) - --- | Exception thrown by 'cancel'. -data CancelContinuation = CancelContinuation - deriving (Show, Exception) +{-# LANGUAGE + BangPatterns, + DataKinds, + DeriveAnyClass, + GADTs, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | = Algebraic effects and named handlers +-- +-- Variant of "Bluefin.Algae" using dynamic exceptions to cancel continuations. +module Bluefin.Algae.DynExn + ( AEffect + , HandlerBody + , Handler + , handle + , call + , continue + , discontinue + , discontinueIO + , cancel + , CancelContinuation(..) + ) where + +import Control.Exception (Exception) +import Data.Kind (Type) +import Data.Functor (void) +import Bluefin.Internal (Eff, Effects, type (:&), type (:>), IOE) +import Bluefin.Algae.DelCont (PromptTag, Continuation, reset, shift0, resume, continue) +import Bluefin.Exception.Dynamic +import Bluefin.Algae (AEffect) + +-- | Interpretation of an algebraic effect @f@: a function to handle the operations of @f@ +-- with cancellable continuations. +type HandlerBody :: Effects -> AEffect -> Effects -> Type -> Type +type HandlerBody ex f ss a = (forall x ss0. ex :> ss0 => f x -> Continuation ss0 ss x a -> Eff ss a) + +-- | Handler to call operations of the effect @f@ with cancellable continuations. +type Handler :: Effects -> AEffect -> Effects -> Type +data Handler ex f s where + MkHandler :: !(PromptTag ss a s) -> HandlerBody ex f ss a -> Handler ex f s + +-- | Handle operations of @f@ with cancellable continuations. +-- +-- The handle for exceptions (first argument) is only there to guide type inference. +-- it can be either 'IOE' or 'DynExn'. +handle :: + h ex -> + HandlerBody ex f ss a -> + (forall s. Handler ex f s -> Eff (s :& ss) a) -> + Eff ss a +handle _ h act = reset (\p -> act (MkHandler p h)) + +-- | Call an operation of @f@ with cancellable continuations. +call :: (ex :> es, s :> es) => Handler ex f s -> f a -> Eff es a +call (MkHandler p h) op = shift0 p (\k -> h op k) + +-- | Resume by throwing a dynamic exception. +-- +-- Note that different outcomes are possible depending on your handled computation. +-- Be sure to handle them appropriately. +-- +-- - A common situation is that the continuation will rethrow the initial exception, +-- then you can just catch it (or use 'cancel'). +-- - The continuation may throw a different exception, so you should be +-- careful to catch the right exception. +-- - The continuation may also catch your exception and terminate normally +-- with a result of type @a@. +discontinue :: (Exception e, ex :> es0) => DynExn ex -> Continuation es0 es b a -> e -> Eff es a +discontinue ex k e = resume k (throw ex e) + +-- | Specialization of 'discontinue' to 'IOE'. +discontinueIO :: (Exception e, io :> es0) => IOE io -> Continuation es0 es b a -> e -> Eff es a +discontinueIO io = discontinue (ioeToDynExn io) + +-- | 'discontinue' a continuation with the v'CancelContinuation' exception and catch it when it +-- is re-thrown by the continuation. +-- +-- The continuation SHOULD re-throw v'CancelContinuation' if it catches it. +cancel :: (ex :> es0, ex :> es) => DynExn ex -> Continuation es0 es b a -> Eff es () +cancel ex k = catch ex (void (discontinue ex k CancelContinuation)) (\CancelContinuation -> pure ()) + +-- | Exception thrown by 'cancel'. +data CancelContinuation = CancelContinuation + deriving (Show, Exception) diff --git a/src/Bluefin/Algae/Exception.hs b/src/Bluefin/Algae/Exception.hs --- a/src/Bluefin/Algae/Exception.hs +++ b/src/Bluefin/Algae/Exception.hs @@ -1,102 +1,102 @@ -{-# LANGUAGE - BangPatterns, - GADTs, - KindSignatures, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | = Exceptions as an algebraic effect --- --- These scoped exceptions are similar to "Bluefin.Exception". --- --- Algebraic operations in Bluefin are truly scoped: --- they cannot be intercepted by exception handlers, notably 'Bluefin.Eff.bracket'. --- --- 'catch' and 'try' make an explicit call to 'cancel' to trigger exception handlers. --- This makes them equivalent to "Bluefin.Exception". --- --- The simpler variants 'catch'' and 'try'' don't use 'cancel', so they are --- faster when there is no 'Bluefin.Eff.bracket' to worry about. -module Bluefin.Algae.Exception - ( -- * Operations - Exception(..) - , throw - - -- * Default handlers - , catch - , try - - -- * Variant without cancelling continuations - , catch' - , try' - ) where - -import Data.Kind (Type) -import Bluefin.Eff (Eff, type (:&), type (:>)) -import Bluefin.Algae - --- | Exception interface. -data Exception (e :: Type) :: AEffect where - -- | Throw an exception. - Throw :: e -> Exception e r - --- | Throw an exception. Call the 'Throw' operation. -throw :: z :> zz => Handler (Exception e) z -> e -> Eff zz a -throw h e = call h (Throw e) - --- | Catch an exception. --- --- Simple version of 'catch' which just discards the continuation --- instead of explicitly cancelling it. --- --- === Warning: Discarded continuations --- --- 'catch'' discards the continuation, which may be problematic --- if there are resources to be freed by the continuation (typically --- if 'throw' was called in the middle of a 'Bluefin.Eff.bracket'). --- Use 'catch' to free those resources instead. --- --- Without anything like 'Bluefin.Eff.bracket', 'catch'' does less work. --- 'catch' makes 'throw' traverse the stack twice (first to find the prompt, --- then to 'cancel' the continuation). --- 'catch'' makes 'throw' traverse the stack only once. -catch' :: forall e a zz. - (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> -- ^ Handled computation - (e -> Eff zz a) -> -- ^ Exception clause - Eff zz a -catch' f h = handle exceptionHandler f - where - exceptionHandler :: HandlerBody (Exception e) zz a - exceptionHandler (Throw e) _ = h e - --- | Return 'Either' the exception or the result of the handled computation. --- --- Simple version of 'try' which discards the continuation (like 'catch''). -try' :: forall e a zz. - (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> - Eff zz (Either e a) -try' f = catch' (fmap Right . f) (pure . Left) - --- | Catch an exception. --- --- The continuation is canceled ('cancel') when --- an exception is thrown to this handler. -catch :: forall e a zz. - (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> - (e -> Eff zz a) -> - Eff zz a -catch f h = handle' exceptionHandler f - where - exceptionHandler :: HandlerBody' (Exception e) zz a - exceptionHandler (Throw e) k = cancel k >> h e - --- | Return 'Either' the exception or the result of the handled computation. --- --- The continuation is canceled ('cancel') when --- an exception is thrown to this handler. -try :: forall e a zz. - (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> - Eff zz (Either e a) -try f = catch (fmap Right . f) (pure . Left) +{-# LANGUAGE + BangPatterns, + GADTs, + KindSignatures, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | = Exceptions as an algebraic effect +-- +-- These scoped exceptions are similar to "Bluefin.Exception". +-- +-- Algebraic operations in Bluefin are truly scoped: +-- they cannot be intercepted by exception handlers, notably 'Bluefin.Eff.bracket'. +-- +-- 'catch' and 'try' make an explicit call to 'cancel' to trigger exception handlers. +-- This makes them equivalent to "Bluefin.Exception". +-- +-- The simpler variants 'catch'' and 'try'' don't use 'cancel', so they are +-- faster when there is no 'Bluefin.Eff.bracket' to worry about. +module Bluefin.Algae.Exception + ( -- * Operations + Exception(..) + , throw + + -- * Default handlers + , catch + , try + + -- * Variant without cancelling continuations + , catch' + , try' + ) where + +import Data.Kind (Type) +import Bluefin.Eff (Eff, type (:&), type (:>)) +import Bluefin.Algae + +-- | Exception interface. +data Exception (e :: Type) :: AEffect where + -- | Throw an exception. + Throw :: e -> Exception e r + +-- | Throw an exception. Call the 'Throw' operation. +throw :: z :> zz => Handler (Exception e) z -> e -> Eff zz a +throw h e = call h (Throw e) + +-- | Catch an exception. +-- +-- Simple version of 'catch' which just discards the continuation +-- instead of explicitly cancelling it. +-- +-- === Warning: Discarded continuations +-- +-- 'catch'' discards the continuation, which may be problematic +-- if there are resources to be freed by the continuation (typically +-- if 'throw' was called in the middle of a 'Bluefin.Eff.bracket'). +-- Use 'catch' to free those resources instead. +-- +-- Without anything like 'Bluefin.Eff.bracket', 'catch'' does less work. +-- 'catch' makes 'throw' traverse the stack twice (first to find the prompt, +-- then to 'cancel' the continuation). +-- 'catch'' makes 'throw' traverse the stack only once. +catch' :: forall e a zz. + (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> -- ^ Handled computation + (e -> Eff zz a) -> -- ^ Exception clause + Eff zz a +catch' f h = handle exceptionHandler f + where + exceptionHandler :: HandlerBody (Exception e) zz a + exceptionHandler (Throw e) _ = h e + +-- | Return 'Either' the exception or the result of the handled computation. +-- +-- Simple version of 'try' which discards the continuation (like 'catch''). +try' :: forall e a zz. + (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> + Eff zz (Either e a) +try' f = catch' (fmap Right . f) (pure . Left) + +-- | Catch an exception. +-- +-- The continuation is canceled ('cancel') when +-- an exception is thrown to this handler. +catch :: forall e a zz. + (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> + (e -> Eff zz a) -> + Eff zz a +catch f h = handle' exceptionHandler f + where + exceptionHandler :: HandlerBody' (Exception e) zz a + exceptionHandler (Throw e) k = cancel k >> h e + +-- | Return 'Either' the exception or the result of the handled computation. +-- +-- The continuation is canceled ('cancel') when +-- an exception is thrown to this handler. +try :: forall e a zz. + (forall z. Handler (Exception e) z -> Eff (z :& zz) a) -> + Eff zz (Either e a) +try f = catch (fmap Right . f) (pure . Left) diff --git a/src/Bluefin/Algae/Exception/DynExn.hs b/src/Bluefin/Algae/Exception/DynExn.hs --- a/src/Bluefin/Algae/Exception/DynExn.hs +++ b/src/Bluefin/Algae/Exception/DynExn.hs @@ -1,45 +1,45 @@ -{-# LANGUAGE - BangPatterns, - GADTs, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | = Exceptions as an algebraic effect --- --- Variant of "Bluefin.Algae.Exception" that uses dynamic exceptions to cancel --- continuations. -module Bluefin.Algae.Exception.DynExn - ( Exception(..) - , throw - , catch - , try - ) where - -import Bluefin.Eff (Eff, type (:&), type (:>)) -import Bluefin.Algae.DynExn -import Bluefin.Algae.Exception (Exception(..)) -import Bluefin.Exception.Dynamic (DynExn) - --- | Catch an exception. -catch :: forall e a ex zz. ex :> zz => - DynExn ex -> - (forall z. Handler ex (Exception e) z -> Eff (z :& zz) a) -> - (e -> Eff zz a) -> - Eff zz a -catch ex f h = handle ex exceptionHandler f - where - exceptionHandler :: HandlerBody ex (Exception e) zz a - exceptionHandler (Throw e) k = cancel ex k *> h e - --- | Return 'Either' the exception or the result of the handled computation. -try :: forall e a ex zz. ex :> zz => - DynExn ex -> - (forall z. Handler ex (Exception e) z -> Eff (z :& zz) a) -> - Eff zz (Either e a) -try ex f = catch ex (fmap Right . f) (pure . Left) - --- | Throw an exception. Call the 'Throw' operation. -throw :: (ex :> zz, z :> zz) => Handler ex (Exception e) z -> e -> Eff zz a -throw h e = call h (Throw e) +{-# LANGUAGE + BangPatterns, + GADTs, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | = Exceptions as an algebraic effect +-- +-- Variant of "Bluefin.Algae.Exception" that uses dynamic exceptions to cancel +-- continuations. +module Bluefin.Algae.Exception.DynExn + ( Exception(..) + , throw + , catch + , try + ) where + +import Bluefin.Eff (Eff, type (:&), type (:>)) +import Bluefin.Algae.DynExn +import Bluefin.Algae.Exception (Exception(..)) +import Bluefin.Exception.Dynamic (DynExn) + +-- | Catch an exception. +catch :: forall e a ex zz. ex :> zz => + DynExn ex -> + (forall z. Handler ex (Exception e) z -> Eff (z :& zz) a) -> + (e -> Eff zz a) -> + Eff zz a +catch ex f h = handle ex exceptionHandler f + where + exceptionHandler :: HandlerBody ex (Exception e) zz a + exceptionHandler (Throw e) k = cancel ex k *> h e + +-- | Return 'Either' the exception or the result of the handled computation. +try :: forall e a ex zz. ex :> zz => + DynExn ex -> + (forall z. Handler ex (Exception e) z -> Eff (z :& zz) a) -> + Eff zz (Either e a) +try ex f = catch ex (fmap Right . f) (pure . Left) + +-- | Throw an exception. Call the 'Throw' operation. +throw :: (ex :> zz, z :> zz) => Handler ex (Exception e) z -> e -> Eff zz a +throw h e = call h (Throw e) diff --git a/src/Bluefin/Algae/NonDeterminism.hs b/src/Bluefin/Algae/NonDeterminism.hs --- a/src/Bluefin/Algae/NonDeterminism.hs +++ b/src/Bluefin/Algae/NonDeterminism.hs @@ -1,95 +1,95 @@ -{-# LANGUAGE - BangPatterns, - GADTs, - KindSignatures, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | Nondeterministic choice as an algebraic effect. --- --- === Warning: Non-linear continuations --- --- The handlers 'forAllChoices' and 'toList' call continuations zero or twice. --- Don't use them to handle a computation that must ensure linear usage of resources. -module Bluefin.Algae.NonDeterminism - ( -- * Operations - Choice(..) - , choose - , nil - , assume - , pick - , removeFrom - -- * Handlers - , forAllChoices - , toList - , foldChoice - ) where - -import Control.Monad ((>=>), join) -import Bluefin.Internal (insertFirst) -import Bluefin.Eff (Eff, type (:&), type (:>)) -import Bluefin.Algae - --- | Choice effect. -data Choice :: AEffect where - -- | Choose one of two alternatives. - Choose :: a -> a -> Choice a - -- | No choice. - Nil :: Choice a - --- | Choose one of two alternatives. Call the 'Choose' operation. -choose :: z :> zz => Handler Choice z -> a -> a -> Eff zz a -choose h x y = call h (Choose x y) - --- | No choice. Call the 'Nil' operation. -nil :: z :> zz => Handler Choice z -> Eff zz a -nil h = call h Nil - --- | Do nothing if @True@. Discard (call 'nil') if @False@. -assume :: z :> zz => Handler Choice z -> Bool -> Eff zz () -assume _ True = pure () -assume h False = nil h - --- | Pick an element in a list. -pick :: z :> zz => Handler Choice z -> [a] -> Eff zz a -pick h [] = nil h -pick h (x : xs) = join $ choose h (pure x) (pick h xs) - --- | Remove an element from a list, returning the resulting list as well. --- The order of elements is preserved. -removeFrom :: z :> zz => Handler Choice z -> [a] -> Eff zz (a, [a]) -removeFrom h = loop [] - where - loop _ [] = nil h - loop ys (x : xs) = join $ choose h (pure (x, reverse ys ++ xs)) (loop (x : ys) xs) - --- | Apply a function to every result of the nondeterministic computation. -forAllChoices :: forall a zz. - (forall z. Handler Choice z -> Eff (z :& zz) a) -> - (a -> Eff zz ()) -> - Eff zz () -forAllChoices f h = foldChoice h (pure ()) (>>) f - --- | Collect the results of a nondeterministic computation in a list. -toList :: forall a zz. - (forall z. Handler Choice z -> Eff (z :& zz) a) -> - Eff zz [a] -toList f = unwrap (foldChoice (pure . (:)) (pure id) (liftA2 (.)) f) - where - unwrap :: Eff zz ([a] -> [a]) -> Eff zz [a] - unwrap = fmap ($ []) - --- | Generic 'Choice' handler parameterized by a monoid. -foldChoice :: forall a r zz. - (a -> Eff zz r) -> -- ^ Injection - Eff zz r -> -- ^ Identity element - (Eff zz r -> Eff zz r -> Eff zz r) -> -- ^ Binary operation - ScopedEff Choice zz a -> - Eff zz r -foldChoice oneE nilE appendE f = handle choiceHandler (f >=> insertFirst . oneE) - where - choiceHandler :: HandlerBody Choice zz r - choiceHandler (Choose x y) k = appendE (k x) (k y) - choiceHandler Nil _k = nilE +{-# LANGUAGE + BangPatterns, + GADTs, + KindSignatures, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | Nondeterministic choice as an algebraic effect. +-- +-- === Warning: Non-linear continuations +-- +-- The handlers 'forAllChoices' and 'toList' call continuations zero or twice. +-- Don't use them to handle a computation that must ensure linear usage of resources. +module Bluefin.Algae.NonDeterminism + ( -- * Operations + Choice(..) + , choose + , nil + , assume + , pick + , removeFrom + -- * Handlers + , forAllChoices + , toList + , foldChoice + ) where + +import Control.Monad ((>=>), join) +import Bluefin.Internal (insertFirst) +import Bluefin.Eff (Eff, type (:&), type (:>)) +import Bluefin.Algae + +-- | Choice effect. +data Choice :: AEffect where + -- | Choose one of two alternatives. + Choose :: a -> a -> Choice a + -- | No choice. + Nil :: Choice a + +-- | Choose one of two alternatives. Call the 'Choose' operation. +choose :: z :> zz => Handler Choice z -> a -> a -> Eff zz a +choose h x y = call h (Choose x y) + +-- | No choice. Call the 'Nil' operation. +nil :: z :> zz => Handler Choice z -> Eff zz a +nil h = call h Nil + +-- | Do nothing if @True@. Discard (call 'nil') if @False@. +assume :: z :> zz => Handler Choice z -> Bool -> Eff zz () +assume _ True = pure () +assume h False = nil h + +-- | Pick an element in a list. +pick :: z :> zz => Handler Choice z -> [a] -> Eff zz a +pick h [] = nil h +pick h (x : xs) = join $ choose h (pure x) (pick h xs) + +-- | Remove an element from a list, returning the resulting list as well. +-- The order of elements is preserved. +removeFrom :: z :> zz => Handler Choice z -> [a] -> Eff zz (a, [a]) +removeFrom h = loop [] + where + loop _ [] = nil h + loop ys (x : xs) = join $ choose h (pure (x, reverse ys ++ xs)) (loop (x : ys) xs) + +-- | Apply a function to every result of the nondeterministic computation. +forAllChoices :: forall a zz. + (forall z. Handler Choice z -> Eff (z :& zz) a) -> + (a -> Eff zz ()) -> + Eff zz () +forAllChoices f h = foldChoice h (pure ()) (>>) f + +-- | Collect the results of a nondeterministic computation in a list. +toList :: forall a zz. + (forall z. Handler Choice z -> Eff (z :& zz) a) -> + Eff zz [a] +toList f = unwrap (foldChoice (pure . (:)) (pure id) (liftA2 (.)) f) + where + unwrap :: Eff zz ([a] -> [a]) -> Eff zz [a] + unwrap = fmap ($ []) + +-- | Generic 'Choice' handler parameterized by a monoid. +foldChoice :: forall a r zz. + (a -> Eff zz r) -> -- ^ Injection + Eff zz r -> -- ^ Identity element + (Eff zz r -> Eff zz r -> Eff zz r) -> -- ^ Binary operation + ScopedEff Choice zz a -> + Eff zz r +foldChoice oneE nilE appendE f = handle choiceHandler (f >=> insertFirst . oneE) + where + choiceHandler :: HandlerBody Choice zz r + choiceHandler (Choose x y) k = appendE (k x) (k y) + choiceHandler Nil _k = nilE diff --git a/src/Bluefin/Algae/Reader.hs b/src/Bluefin/Algae/Reader.hs --- a/src/Bluefin/Algae/Reader.hs +++ b/src/Bluefin/Algae/Reader.hs @@ -1,39 +1,39 @@ -{-# LANGUAGE - DataKinds, - GADTs, - KindSignatures, - RankNTypes, - ScopedTypeVariables, - TypeOperators #-} --- | = Reader as an algebraic effect --- --- Access to a read-only environment. -module Bluefin.Algae.Reader - ( -- * Operation - Reader(..) - , ask - - -- * Handler - , runReader - ) where - -import Data.Kind (Type) -import Bluefin.Algae -import Bluefin.Eff (Eff, type (:>), type (:&)) - --- | The reader effect. -data Reader (a :: Type) :: AEffect where - -- | Ask for a value. - Ask :: Reader a a - --- | Ask for a value. Call the 'Ask' operation. -ask :: s :> ss => Handler (Reader a) s -> Eff ss a -ask h = call h Ask - --- | Answer 'Ask' operations of the handled computation with a fixed value. -runReader :: forall a b ss. - a -> (forall s. Handler (Reader a) s -> Eff (s :& ss) b) -> Eff ss b -runReader a = handle readerHandler - where - readerHandler :: Reader a r -> (r -> Eff ss b) -> Eff ss b - readerHandler Ask k = k a +{-# LANGUAGE + DataKinds, + GADTs, + KindSignatures, + RankNTypes, + ScopedTypeVariables, + TypeOperators #-} +-- | = Reader as an algebraic effect +-- +-- Access to a read-only environment. +module Bluefin.Algae.Reader + ( -- * Operation + Reader(..) + , ask + + -- * Handler + , runReader + ) where + +import Data.Kind (Type) +import Bluefin.Algae +import Bluefin.Eff (Eff, type (:>), type (:&)) + +-- | The reader effect. +data Reader (a :: Type) :: AEffect where + -- | Ask for a value. + Ask :: Reader a a + +-- | Ask for a value. Call the 'Ask' operation. +ask :: s :> ss => Handler (Reader a) s -> Eff ss a +ask h = call h Ask + +-- | Answer 'Ask' operations of the handled computation with a fixed value. +runReader :: forall a b ss. + a -> (forall s. Handler (Reader a) s -> Eff (s :& ss) b) -> Eff ss b +runReader a = handle readerHandler + where + readerHandler :: Reader a r -> (r -> Eff ss b) -> Eff ss b + readerHandler Ask k = k a diff --git a/src/Bluefin/Algae/State.hs b/src/Bluefin/Algae/State.hs --- a/src/Bluefin/Algae/State.hs +++ b/src/Bluefin/Algae/State.hs @@ -1,100 +1,100 @@ -{-# LANGUAGE - BangPatterns, - GADTs, - KindSignatures, - RankNTypes, - ScopedTypeVariables, - StandaloneKindSignatures, - TypeOperators #-} - --- | = State as an algebraic effect --- --- The 'runState' handler calls each continuation exactly once. --- It is compatible with single-shot continuations. -module Bluefin.Algae.State - ( -- * Operations - State(..) - , get - , put - , putL - , modify - , modifyL - - -- * Handlers - , runState - , evalState - , execState - ) where - -import Data.Kind (Type) -import Bluefin.Eff (Eff, type (:&), type (:>)) -import Bluefin.Algae - --- | The state effect. -data State (s :: Type) :: AEffect where - -- | Get the current state. - Get :: State s s - -- | Put a new state. - Put :: s -> State s () - --- | Get the current state. Call the 'Get' operation. -get :: z :> zz => Handler (State s) z -> Eff zz s -get h = call h Get - --- | Put a new state. Call the 'Put' operation. --- --- This function is strict. -put :: z :> zz => Handler (State s) z -> s -> Eff zz () -put h !s = call h (Put s) - --- | Lazy variant of 'put'. -putL :: z :> zz => Handler (State s) z -> s -> Eff zz () -putL h s = call h (Put s) - --- | Modify the state. --- --- This function is strict in the modified state. -modify :: z :> zz => Handler (State s) z -> (s -> s) -> Eff zz () -modify h f = get h >>= put h . f - --- | Lazy variant of 'modify'. -modifyL :: z :> zz => Handler (State s) z -> (s -> s) -> Eff zz () -modifyL h f = get h >>= putL h . f - --- | Run a stateful computation from the given starting state. -runState :: - s -> -- ^ Initial state - (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation - Eff zz (a, s) -runState = runStateWith (,) - --- | Variant of 'runState' that returns only the result value. -evalState :: - s -> -- ^ Initial state - (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation - Eff zz a -evalState = runStateWith const - --- | Variant of 'runState' that returns only the final state. -execState :: - s -> -- ^ Initial state - (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation - Eff zz s -execState = runStateWith (const id) - -runStateWith :: forall s a r zz. - (a -> s -> r) -> -- ^ Combine the result and final state. - s -> -- ^ Initial state - (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation - Eff zz r -runStateWith finish s0 f = unwrap s0 (handle stateHandler (wrap . f)) - where - stateHandler :: HandlerBody (State s) zz (s -> Eff zz r) - stateHandler Get k = pure (\s -> k s >>= \k1 -> k1 s) - stateHandler (Put s) k = pure (\_ -> k () >>= \k1 -> k1 s) - - wrap :: Eff (z :& zz) a -> Eff (z :& zz) (s -> Eff zz r) - wrap = fmap (\a s -> pure (finish a s)) - - unwrap :: s -> Eff zz (s -> Eff zz r) -> Eff zz r - unwrap s m = m >>= \k -> k s +{-# LANGUAGE + BangPatterns, + GADTs, + KindSignatures, + RankNTypes, + ScopedTypeVariables, + StandaloneKindSignatures, + TypeOperators #-} + +-- | = State as an algebraic effect +-- +-- The 'runState' handler calls each continuation exactly once. +-- It is compatible with single-shot continuations. +module Bluefin.Algae.State + ( -- * Operations + State(..) + , get + , put + , putL + , modify + , modifyL + + -- * Handlers + , runState + , evalState + , execState + ) where + +import Data.Kind (Type) +import Bluefin.Eff (Eff, type (:&), type (:>)) +import Bluefin.Algae + +-- | The state effect. +data State (s :: Type) :: AEffect where + -- | Get the current state. + Get :: State s s + -- | Put a new state. + Put :: s -> State s () + +-- | Get the current state. Call the 'Get' operation. +get :: z :> zz => Handler (State s) z -> Eff zz s +get h = call h Get + +-- | Put a new state. Call the 'Put' operation. +-- +-- This function is strict. +put :: z :> zz => Handler (State s) z -> s -> Eff zz () +put h !s = call h (Put s) + +-- | Lazy variant of 'put'. +putL :: z :> zz => Handler (State s) z -> s -> Eff zz () +putL h s = call h (Put s) + +-- | Modify the state. +-- +-- This function is strict in the modified state. +modify :: z :> zz => Handler (State s) z -> (s -> s) -> Eff zz () +modify h f = get h >>= put h . f + +-- | Lazy variant of 'modify'. +modifyL :: z :> zz => Handler (State s) z -> (s -> s) -> Eff zz () +modifyL h f = get h >>= putL h . f + +-- | Run a stateful computation from the given starting state. +runState :: + s -> -- ^ Initial state + (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation + Eff zz (a, s) +runState = runStateWith (,) + +-- | Variant of 'runState' that returns only the result value. +evalState :: + s -> -- ^ Initial state + (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation + Eff zz a +evalState = runStateWith const + +-- | Variant of 'runState' that returns only the final state. +execState :: + s -> -- ^ Initial state + (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation + Eff zz s +execState = runStateWith (const id) + +runStateWith :: forall s a r zz. + (a -> s -> r) -> -- ^ Combine the result and final state. + s -> -- ^ Initial state + (forall z. Handler (State s) z -> Eff (z :& zz) a) -> -- ^ Stateful computation + Eff zz r +runStateWith finish s0 f = unwrap s0 (handle stateHandler (wrap . f)) + where + stateHandler :: HandlerBody (State s) zz (s -> Eff zz r) + stateHandler Get k = pure (\s -> k s >>= \k1 -> k1 s) + stateHandler (Put s) k = pure (\_ -> k () >>= \k1 -> k1 s) + + wrap :: Eff (z :& zz) a -> Eff (z :& zz) (s -> Eff zz r) + wrap = fmap (\a s -> pure (finish a s)) + + unwrap :: s -> Eff zz (s -> Eff zz r) -> Eff zz r + unwrap s m = m >>= \k -> k s diff --git a/src/Bluefin/Exception/Dynamic.hs b/src/Bluefin/Exception/Dynamic.hs --- a/src/Bluefin/Exception/Dynamic.hs +++ b/src/Bluefin/Exception/Dynamic.hs @@ -1,85 +1,86 @@ -{-# LANGUAGE - KindSignatures, - RankNTypes, - ScopedTypeVariables, - TypeOperators #-} --- | = Dynamic exceptions --- --- This is the vanilla exception mechanism from @IO@. --- Use this module to handle exceptions from external (non-bluefin) APIs. --- --- Another motivation is to serve as a principled (experimental) framework --- for resource management with 'bracket'. --- --- The core Bluefin API exposes a 'Bluefin.Eff.bracket' in "Bluefin.Eff" --- which (intentionally) weakens the scoping of scoped exceptions in --- "Bluefin.Exception". --- --- This module is an experiment for a world where --- --- - scoped exceptions are truly scoped (unlike "Bluefin.Exception"); --- - the capability to catch and throw dynamic exceptions is explicit --- (unlike 'Bluefin.Eff.bracket' in "Bluefin.Eff"). -module Bluefin.Exception.Dynamic - ( DynExn - , runDynExn - , ioeToDynExn - , throw - , catch - , bracket - , finally - , onException - , throwIO - , catchIO - ) where - -import qualified Control.Exception as E -import qualified Bluefin.Internal as B -import Bluefin.Eff (Eff, Effects, type (:>)) -import Bluefin.IO (IOE) - --- | Capability to catch and throw dynamic exceptions. -data DynExn (ex :: Effects) = UnsafeDynExn - --- | Run a computation with only access to dynamic exceptions. -runDynExn :: (forall ex. DynExn ex -> Eff ex a) -> a -runDynExn f = B.runPureEff (f UnsafeDynExn) - --- | Refine an 'IOE' capability to a 'DynExn'. -ioeToDynExn :: IOE io -> DynExn io -ioeToDynExn _ = UnsafeDynExn - --- | Throw an exception. -throw :: (E.Exception e, ex :> es) => DynExn ex -> e -> Eff es a -throw _ e = B.UnsafeMkEff (E.throwIO e) - --- | Catch an exception. -catch :: (E.Exception e, ex :> es) => DynExn ex -> Eff es a -> (e -> Eff es a) -> Eff es a -catch _ m h = B.UnsafeMkEff (E.catch (B.unsafeUnEff m) (B.unsafeUnEff . h)) - --- | @'bracket' ex acquire release run@: @acquire@ a resource, @run@ a computation depending on it, --- and finally @relase@ the resource even if @run@ threw an exception. -bracket :: ex :> es => DynExn ex -> Eff es a -> (a -> Eff es ()) -> (a -> Eff es b) -> Eff es b -bracket ex acquire release run = do - a <- acquire - finally ex (run a) (release a) - --- | @'finally' ex run cleanup@: @run@ a computation, then @cleanup@ even if --- @run@ threw an exception. -finally :: ex :> es => DynExn ex -> Eff es a -> Eff es () -> Eff es a -finally ex run cleanup = - onException ex run cleanup -- if run throws an exception, then only this cleanup will run - <* cleanup -- if run does not throw, then only this cleanup will run - --- | @'onException' ex run cleanup@: @run@ a computation, and if an exception is thrown, --- @cleanup@, then rethrow the exception. -onException :: ex :> es => DynExn ex -> Eff es a -> Eff es () -> Eff es a -onException ex run cleanup = catch ex run (\(e :: E.SomeException) -> cleanup >> throw ex e) - --- | 'throw' with an 'IOE' capability. -throwIO :: (E.Exception e, io :> es) => IOE io -> e -> Eff es a -throwIO io = throw (ioeToDynExn io) - --- | 'catch' with an 'IOE' capability. -catchIO :: (E.Exception e, io :> es) => IOE io -> Eff es a -> (e -> Eff es a) -> Eff es a -catchIO io = catch (ioeToDynExn io) +{-# LANGUAGE + DataKinds, + KindSignatures, + RankNTypes, + ScopedTypeVariables, + TypeOperators #-} +-- | = Dynamic exceptions +-- +-- This is the vanilla exception mechanism from @IO@. +-- Use this module to handle exceptions from external (non-bluefin) APIs. +-- +-- Another motivation is to serve as a principled (experimental) framework +-- for resource management with 'bracket'. +-- +-- The core Bluefin API exposes a 'Bluefin.Eff.bracket' in "Bluefin.Eff" +-- which (intentionally) weakens the scoping of scoped exceptions in +-- "Bluefin.Exception". +-- +-- This module is an experiment for a world where +-- +-- - scoped exceptions are truly scoped (unlike "Bluefin.Exception"); +-- - the capability to catch and throw dynamic exceptions is explicit +-- (unlike 'Bluefin.Eff.bracket' in "Bluefin.Eff"). +module Bluefin.Exception.Dynamic + ( DynExn + , runDynExn + , ioeToDynExn + , throw + , catch + , bracket + , finally + , onException + , throwIO + , catchIO + ) where + +import qualified Control.Exception as E +import qualified Bluefin.Internal as B +import Bluefin.Eff (Eff, Effects, type (:>)) +import Bluefin.IO (IOE) + +-- | Capability to catch and throw dynamic exceptions. +data DynExn (ex :: Effects) = UnsafeDynExn + +-- | Run a computation with only access to dynamic exceptions. +runDynExn :: (forall ex. DynExn ex -> Eff ex a) -> a +runDynExn f = B.runPureEff (f UnsafeDynExn) + +-- | Refine an 'IOE' capability to a 'DynExn'. +ioeToDynExn :: IOE io -> DynExn io +ioeToDynExn _ = UnsafeDynExn + +-- | Throw an exception. +throw :: (E.Exception e, ex :> es) => DynExn ex -> e -> Eff es a +throw _ e = B.UnsafeMkEff (E.throwIO e) + +-- | Catch an exception. +catch :: (E.Exception e, ex :> es) => DynExn ex -> Eff es a -> (e -> Eff es a) -> Eff es a +catch _ m h = B.UnsafeMkEff (E.catch (B.unsafeUnEff m) (B.unsafeUnEff . h)) + +-- | @'bracket' ex acquire release run@: @acquire@ a resource, @run@ a computation depending on it, +-- and finally @relase@ the resource even if @run@ threw an exception. +bracket :: ex :> es => DynExn ex -> Eff es a -> (a -> Eff es ()) -> (a -> Eff es b) -> Eff es b +bracket ex acquire release run = do + a <- acquire + finally ex (run a) (release a) + +-- | @'finally' ex run cleanup@: @run@ a computation, then @cleanup@ even if +-- @run@ threw an exception. +finally :: ex :> es => DynExn ex -> Eff es a -> Eff es () -> Eff es a +finally ex run cleanup = + onException ex run cleanup -- if run throws an exception, then only this cleanup will run + <* cleanup -- if run does not throw, then only this cleanup will run + +-- | @'onException' ex run cleanup@: @run@ a computation, and if an exception is thrown, +-- @cleanup@, then rethrow the exception. +onException :: ex :> es => DynExn ex -> Eff es a -> Eff es () -> Eff es a +onException ex run cleanup = catch ex run (\(e :: E.SomeException) -> cleanup >> throw ex e) + +-- | 'throw' with an 'IOE' capability. +throwIO :: (E.Exception e, io :> es) => IOE io -> e -> Eff es a +throwIO io = throw (ioeToDynExn io) + +-- | 'catch' with an 'IOE' capability. +catchIO :: (E.Exception e, io :> es) => IOE io -> Eff es a -> (e -> Eff es a) -> Eff es a +catchIO io = catch (ioeToDynExn io) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,288 +1,288 @@ -{-# LANGUAGE - BangPatterns, - BlockArguments, - DataKinds, - RankNTypes, - ScopedTypeVariables, - TypeApplications, - TypeOperators #-} -module Main (main) where - -import Control.Monad (join) -import Data.Functor (void) -import Data.Void (absurd) -import Test.Tasty (defaultMain, testGroup, TestTree) -import Test.Tasty.HUnit -import Bluefin.Eff (Eff, runPureEff, bracket, type (:&), type (:>)) -import qualified Bluefin.State as B -import Bluefin.Algae -import Bluefin.Algae.State -import Bluefin.Algae.Exception -import qualified Bluefin.Algae.Exception.DynExn as EC -import Bluefin.Algae.NonDeterminism as NonDet -import Bluefin.Algae.Coroutine -import qualified Bluefin.Exception as E -import qualified Bluefin.Exception.Dynamic as ED - --- * State - --- Simple sanity test - -incr :: z :> zz => Handler (State Int) z -> Eff zz () -incr state = modify state (+ 1) - --- Distinguishing Bluefin.Algae.State (pure state) from Bluefin.State (IORef) - -algaeStateLitmus :: [Int] -algaeStateLitmus = runPureEff $ NonDet.toList \choice -> - execState 0 \state -> do - _ <- choose choice True False - incr state - -bluefinStateLitmus :: [Int] -bluefinStateLitmus = runPureEff $ NonDet.toList \choice -> - snd <$> B.runState 0 \state -> do - _ <- choose choice True False - B.modify state (+ 1) - -testState :: TestTree -testState = testGroup "State" - [ testCase "simple" $ runPureEff (runState 0 incr) @?= ((), 1) - , testCase "litmus-0" $ algaeStateLitmus @?= [1,1] - , testCase "litmus-1" $ bluefinStateLitmus @?= [1,2] - ] - --- * Exception - -onException :: Eff es a -> Eff es () -> Eff es a -onException run post = bracket (pure ()) (\_ -> post) (\_ -> run) - -exceptionLitmus :: Int -exceptionLitmus = runPureEff $ snd <$> runState 0 \state -> - void (try \exn -> - onException (throw exn ()) (incr state)) - -exceptionDynLitmus :: Int -exceptionDynLitmus = ED.runDynExn \ex -> snd <$> runState 0 \state -> - void (EC.try ex \exn -> - onException (EC.throw exn ()) (incr state)) - -exceptionNoCancelLitmus :: Int -exceptionNoCancelLitmus = runPureEff $ snd <$> runState 0 \state -> - void (try' \exn -> - onException (throw exn ()) (incr state)) - -exnLitmus :: Int -exnLitmus = runPureEff $ snd <$> runState 0 \state -> - void (E.try \exn -> - onException (E.throw exn ()) (incr state)) - -testException :: TestTree -testException = testGroup "Exception" - [ testCase "litmus-exception" $ exceptionLitmus @?= 1 - , testCase "litmus-exception-dyn" $ exceptionDynLitmus @?= 1 - , testCase "litmus-exception-no-cancel" $ exceptionNoCancelLitmus @?= 0 - , testCase "litmus-exn" $ exnLitmus @?= 1 - ] - --- * Nondeterminism - -coinFlip :: z :> zz => Handler Choice z -> Eff zz Bool -coinFlip choice = - join $ choose choice -- flip coin - (nil choice) -- coin falls in gutter - (join $ choose choice - (pure True) -- heads - (pure False)) -- tails - -coinFlipList :: [Bool] -coinFlipList = runPureEff (NonDet.toList coinFlip) - -toStream :: z :> zz => - (forall z0. Handler Choice z0 -> Eff (z0 :& zz) a) -> - Handler (Coroutine a ()) z -> Eff zz () -toStream f h = forAllChoices f (yield h) - -permuts :: z :> zz => Handler Choice z -> [a] -> Eff zz [a] -permuts _ [] = pure [] -permuts choice xs = do - (x, ys) <- removeFrom choice xs - zs <- permuts choice ys - pure (x : zs) - -pythagoras :: z :> zz => Handler Choice z -> Eff zz (Int, Int, Int) -pythagoras choice = do - x <- pick choice [1 .. 10] - y <- pick choice [1 .. 10] - z <- pick choice [1 .. 10] - assume choice (x .^ 2 + y .^ 2 == z .^ 2) - pure (x, y, z) - where (.^) = (Prelude.^) :: Int -> Int -> Int - -testNonDet :: TestTree -testNonDet = testGroup "NonDet" - [ testCase "coin-flip" $ coinFlipList @?= [True, False] - , testCase "via-stream" $ runPureEff (feedCoroutine [(), ()] (toStream coinFlip)) @?= [True, False] - , testCase "permutations" $ runPureEff (NonDet.toList (flip permuts [1,2,3::Int])) - @?= [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]] - , testCase "pythagoras" $ runPureEff (NonDet.toList pythagoras) - @?= [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] - ] - --- * Streaming - -cumulSum :: z :> zz => Handler (Coroutine Int Int) z -> Eff zz a -cumulSum h = loop 0 where - loop !n = do - m <- yield h n - loop (m + n) - -feedCoroutine :: [i] -> (forall zz0. ScopedEff (Coroutine o i) zz0 a) -> Eff zz [o] -feedCoroutine is f = do - r <- try \exn -> runState (is, []) \state -> - forCoroutine f (coyield state exn) - pure $ reverse $ case r of - Left os -> os - Right (_, (_, os)) -> os - -coyield :: (z :> zz, z' :> zz) => - Handler (State ([i], [o])) z -> Handler (Exception [o]) z' -> o -> Eff zz i -coyield state exn o = do - (is, os) <- get state - case is of - [] -> throw exn (o : os) - i : ys -> put state (ys, o : os) >> pure i - --- * Concurrency - -range1to4 :: z :> zz => Handler (Coroutine Int ()) z -> Eff zz () -range1to4 h = do - yield h 1 - yield h 2 - yield h 3 - yield h 4 - -filterEven :: z :> zz => Handler (State [Int]) z -> Eff zz () -filterEven h = - forCoroutine range1to4 \n -> - if n `mod` 2 == 0 - then modify h (n :) - else pure () - -filterEvenResult :: Eff zz [Int] -filterEvenResult = execState [] filterEven - -pingpong :: Eff ss String -pingpong = withCoroutine coThread mainThread - where - coThread z0 h = do - z1 <- yield h (z0 ++ "pong") - z2 <- yield h (z1 ++ "dong") - yield h (z2 ++ "bong") - mainThread h = do - s1 <- yield h "ping" - s2 <- yield h (s1 ++ "ding") - s3 <- yield h (s2 ++ "bing") - pure s3 - -echo :: Eff ss String -echo = loopCoPipe ((userLL |+ userLR) |+ (userRL |+ userRR)) (Left (Left "S")) - where - userLL = toCoPipe \s h -> do - s' <- yield h (Left (Right (s ++ "-LL"))) - yield h (Right (Left (s' ++ "-LL"))) - userLR = toCoPipe \s h -> do - s' <- yield h (Right (Left (s ++ "-LR"))) - yield h (Right (Right (s' ++ "-LR"))) - userRL = toCoPipe \s h -> do - s' <- yield h (Right (Right (s ++ "-RL"))) - yield h (Left (Right (s' ++ "-RL"))) - userRR = toCoPipe \s h -> do - s' <- yield h (Left (Left (s ++ "-RR"))) - pure (s' ++ "-RR") - (|+) = eitherCoPipe id - --- | Coroutine identifier -newtype Cid = Cid Int deriving (Eq, Show) - --- | Next coroutine identifier (wraps around at maxCid). -nextCid :: Cid -> Cid -nextCid (Cid c) = Cid (c + 1) - -type Yell a = Exception a - --- | Hot potato coroutine: --- --- - receive hot @potato@ (whose value represents the temperature of the potato); --- - if it is too hot (@potato > 0@), pass the potato to the next coroutine, --- the potato cools down slightly at every pass; --- - once the potato is cool enough, the coroutine which owns the potato yells its @Cid@. -hotpotato :: (z :> zz, z' :> zz) => - Handler (Yell Cid) z -> -- ^ the coroutine may yell using this handle - Cid -> -- ^ coroutine ID - Int -> -- ^ hot @potato@ - Handler (Coroutine (Cid, Int) Int) z' -> -- ^ handle to yield to another coroutine - Eff zz void -- ^ does not return (the yell is an exception) -hotpotato yell c potato0 cr = loop potato0 where - loop potato | potato > 0 = do -- if potato is too hot, - potato' <- yield cr (nextCid c, potato - 1) -- pass to the next coroutine, the potato cools down, - loop potato' -- wait for the potato to come back and repeat. - loop _ | otherwise = throw yell c -- if potato has cooled down, we won the potato. - --- | Four coroutines play the hot potato game. -hotpotatoes :: Eff ss Cid -hotpotatoes = do - e <- try \yell -> - -- Wrap Cid into [0 .. 3] - let wrapCid = mapCoPipe id (\(Cid n, potato) -> (Cid (n `mod` 4), potato)) id in - loopCoPipe (wrapCid - ( hotpotato yell (Cid 0) - +| hotpotato yell (Cid 1) - +| hotpotato yell (Cid 2) - +| hotpotato yell (Cid 3) - +| nobody)) (Cid 3, 42) - case e of - Left c -> pure c - Right o -> absurd o - --- | Empty copipe -nobody :: CoPipe (Cid, Int) o (Eff zz) void -nobody = mapCoPipe (\(_, _) -> error "don't call me") id id voidCoPipe - -infixr 4 +| - --- | Add another hot potato coroutine to the mix. --- --- The coroutines are numbered sequentially. -(+|) :: - CoPipeSEff i o zz a -> - CoPipe (Cid, i) o (Eff zz) a -> - CoPipe (Cid, i) o (Eff zz) a -(+|) l r = eitherCoPipe split l' r - where - l' = mapCoPipe (\(_ :: Cid, potato) -> potato) id id (toCoPipe l) - -split :: (Cid, i) -> Either (Cid, i) (Cid, i) -split (Cid 0, potato) = Left (Cid 0, potato) -split (Cid c, potato) = Right (Cid (c-1), potato) - -testCoroutine :: TestTree -testCoroutine = testGroup "Coroutine" - [ testCase "feedPipe-sum" $ runPureEff (feedPipe [1,2,3] (toPipe cumulSum)) @?= [0,1,3,6] - , testCase "feedCoroutine-sum" $ runPureEff (feedCoroutine [1,2,3] cumulSum) @?= [0,1,3,6] - , testCase "filterEven" $ runPureEff filterEvenResult @?= [4,2] - , testCase "pingpong" $ runPureEff pingpong @?= "pingpongdingdongbingbong" - , testCase "echo" $ runPureEff echo @?= "S-LL-LR-RL-RR-LL-RL-LR-RR" - , testCase "hotpotato" $ runPureEff hotpotatoes @?= Cid 1 - ] - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "Tests" - [ testState - , testException - , testNonDet - , testCoroutine - ] +{-# LANGUAGE + BangPatterns, + BlockArguments, + DataKinds, + RankNTypes, + ScopedTypeVariables, + TypeApplications, + TypeOperators #-} +module Main (main) where + +import Control.Monad (join) +import Data.Functor (void) +import Data.Void (absurd) +import Test.Tasty (defaultMain, testGroup, TestTree) +import Test.Tasty.HUnit +import Bluefin.Eff (Eff, runPureEff, bracket, type (:&), type (:>)) +import qualified Bluefin.State as B +import Bluefin.Algae +import Bluefin.Algae.State +import Bluefin.Algae.Exception +import qualified Bluefin.Algae.Exception.DynExn as EC +import Bluefin.Algae.NonDeterminism as NonDet +import Bluefin.Algae.Coroutine +import qualified Bluefin.Exception as E +import qualified Bluefin.Exception.Dynamic as ED + +-- * State + +-- Simple sanity test + +incr :: z :> zz => Handler (State Int) z -> Eff zz () +incr state = modify state (+ 1) + +-- Distinguishing Bluefin.Algae.State (pure state) from Bluefin.State (IORef) + +algaeStateLitmus :: [Int] +algaeStateLitmus = runPureEff $ NonDet.toList \choice -> + execState 0 \state -> do + _ <- choose choice True False + incr state + +bluefinStateLitmus :: [Int] +bluefinStateLitmus = runPureEff $ NonDet.toList \choice -> + snd <$> B.runState 0 \state -> do + _ <- choose choice True False + B.modify state (+ 1) + +testState :: TestTree +testState = testGroup "State" + [ testCase "simple" $ runPureEff (runState 0 incr) @?= ((), 1) + , testCase "litmus-0" $ algaeStateLitmus @?= [1,1] + , testCase "litmus-1" $ bluefinStateLitmus @?= [1,2] + ] + +-- * Exception + +onException :: Eff es a -> Eff es () -> Eff es a +onException run post = bracket (pure ()) (\_ -> post) (\_ -> run) + +exceptionLitmus :: Int +exceptionLitmus = runPureEff $ snd <$> runState 0 \state -> + void (try \exn -> + onException (throw exn ()) (incr state)) + +exceptionDynLitmus :: Int +exceptionDynLitmus = ED.runDynExn \ex -> snd <$> runState 0 \state -> + void (EC.try ex \exn -> + onException (EC.throw exn ()) (incr state)) + +exceptionNoCancelLitmus :: Int +exceptionNoCancelLitmus = runPureEff $ snd <$> runState 0 \state -> + void (try' \exn -> + onException (throw exn ()) (incr state)) + +exnLitmus :: Int +exnLitmus = runPureEff $ snd <$> runState 0 \state -> + void (E.try \exn -> + onException (E.throw exn ()) (incr state)) + +testException :: TestTree +testException = testGroup "Exception" + [ testCase "litmus-exception" $ exceptionLitmus @?= 1 + , testCase "litmus-exception-dyn" $ exceptionDynLitmus @?= 1 + , testCase "litmus-exception-no-cancel" $ exceptionNoCancelLitmus @?= 0 + , testCase "litmus-exn" $ exnLitmus @?= 1 + ] + +-- * Nondeterminism + +coinFlip :: z :> zz => Handler Choice z -> Eff zz Bool +coinFlip choice = + join $ choose choice -- flip coin + (nil choice) -- coin falls in gutter + (join $ choose choice + (pure True) -- heads + (pure False)) -- tails + +coinFlipList :: [Bool] +coinFlipList = runPureEff (NonDet.toList coinFlip) + +toStream :: z :> zz => + (forall z0. Handler Choice z0 -> Eff (z0 :& zz) a) -> + Handler (Coroutine a ()) z -> Eff zz () +toStream f h = forAllChoices f (yield h) + +permuts :: z :> zz => Handler Choice z -> [a] -> Eff zz [a] +permuts _ [] = pure [] +permuts choice xs = do + (x, ys) <- removeFrom choice xs + zs <- permuts choice ys + pure (x : zs) + +pythagoras :: z :> zz => Handler Choice z -> Eff zz (Int, Int, Int) +pythagoras choice = do + x <- pick choice [1 .. 10] + y <- pick choice [1 .. 10] + z <- pick choice [1 .. 10] + assume choice (x .^ 2 + y .^ 2 == z .^ 2) + pure (x, y, z) + where (.^) = (Prelude.^) :: Int -> Int -> Int + +testNonDet :: TestTree +testNonDet = testGroup "NonDet" + [ testCase "coin-flip" $ coinFlipList @?= [True, False] + , testCase "via-stream" $ runPureEff (feedCoroutine [(), ()] (toStream coinFlip)) @?= [True, False] + , testCase "permutations" $ runPureEff (NonDet.toList (flip permuts [1,2,3::Int])) + @?= [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]] + , testCase "pythagoras" $ runPureEff (NonDet.toList pythagoras) + @?= [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] + ] + +-- * Streaming + +cumulSum :: z :> zz => Handler (Coroutine Int Int) z -> Eff zz a +cumulSum h = loop 0 where + loop !n = do + m <- yield h n + loop (m + n) + +feedCoroutine :: [i] -> (forall zz0. ScopedEff (Coroutine o i) zz0 a) -> Eff zz [o] +feedCoroutine is f = do + r <- try \exn -> runState (is, []) \state -> + forCoroutine f (coyield state exn) + pure $ reverse $ case r of + Left os -> os + Right (_, (_, os)) -> os + +coyield :: (z :> zz, z' :> zz) => + Handler (State ([i], [o])) z -> Handler (Exception [o]) z' -> o -> Eff zz i +coyield state exn o = do + (is, os) <- get state + case is of + [] -> throw exn (o : os) + i : ys -> put state (ys, o : os) >> pure i + +-- * Concurrency + +range1to4 :: z :> zz => Handler (Coroutine Int ()) z -> Eff zz () +range1to4 h = do + yield h 1 + yield h 2 + yield h 3 + yield h 4 + +filterEven :: z :> zz => Handler (State [Int]) z -> Eff zz () +filterEven h = + forCoroutine range1to4 \n -> + if n `mod` 2 == 0 + then modify h (n :) + else pure () + +filterEvenResult :: Eff zz [Int] +filterEvenResult = execState [] filterEven + +pingpong :: Eff ss String +pingpong = withCoroutine coThread mainThread + where + coThread z0 h = do + z1 <- yield h (z0 ++ "pong") + z2 <- yield h (z1 ++ "dong") + yield h (z2 ++ "bong") + mainThread h = do + s1 <- yield h "ping" + s2 <- yield h (s1 ++ "ding") + s3 <- yield h (s2 ++ "bing") + pure s3 + +echo :: Eff ss String +echo = loopCoPipe ((userLL |+ userLR) |+ (userRL |+ userRR)) (Left (Left "S")) + where + userLL = toCoPipe \s h -> do + s' <- yield h (Left (Right (s ++ "-LL"))) + yield h (Right (Left (s' ++ "-LL"))) + userLR = toCoPipe \s h -> do + s' <- yield h (Right (Left (s ++ "-LR"))) + yield h (Right (Right (s' ++ "-LR"))) + userRL = toCoPipe \s h -> do + s' <- yield h (Right (Right (s ++ "-RL"))) + yield h (Left (Right (s' ++ "-RL"))) + userRR = toCoPipe \s h -> do + s' <- yield h (Left (Left (s ++ "-RR"))) + pure (s' ++ "-RR") + (|+) = eitherCoPipe id + +-- | Coroutine identifier +newtype Cid = Cid Int deriving (Eq, Show) + +-- | Next coroutine identifier (wraps around at maxCid). +nextCid :: Cid -> Cid +nextCid (Cid c) = Cid (c + 1) + +type Yell a = Exception a + +-- | Hot potato coroutine: +-- +-- - receive hot @potato@ (whose value represents the temperature of the potato); +-- - if it is too hot (@potato > 0@), pass the potato to the next coroutine, +-- the potato cools down slightly at every pass; +-- - once the potato is cool enough, the coroutine which owns the potato yells its @Cid@. +hotpotato :: (z :> zz, z' :> zz) => + Handler (Yell Cid) z -> -- ^ the coroutine may yell using this handle + Cid -> -- ^ coroutine ID + Int -> -- ^ hot @potato@ + Handler (Coroutine (Cid, Int) Int) z' -> -- ^ handle to yield to another coroutine + Eff zz void -- ^ does not return (the yell is an exception) +hotpotato yell c potato0 cr = loop potato0 where + loop potato | potato > 0 = do -- if potato is too hot, + potato' <- yield cr (nextCid c, potato - 1) -- pass to the next coroutine, the potato cools down, + loop potato' -- wait for the potato to come back and repeat. + loop _ | otherwise = throw yell c -- if potato has cooled down, we won the potato. + +-- | Four coroutines play the hot potato game. +hotpotatoes :: Eff ss Cid +hotpotatoes = do + e <- try \yell -> + -- Wrap Cid into [0 .. 3] + let wrapCid = mapCoPipe id (\(Cid n, potato) -> (Cid (n `mod` 4), potato)) id in + loopCoPipe (wrapCid + ( hotpotato yell (Cid 0) + +| hotpotato yell (Cid 1) + +| hotpotato yell (Cid 2) + +| hotpotato yell (Cid 3) + +| nobody)) (Cid 3, 42) + case e of + Left c -> pure c + Right o -> absurd o + +-- | Empty copipe +nobody :: CoPipe (Cid, Int) o (Eff zz) void +nobody = mapCoPipe (\(_, _) -> error "don't call me") id id voidCoPipe + +infixr 4 +| + +-- | Add another hot potato coroutine to the mix. +-- +-- The coroutines are numbered sequentially. +(+|) :: + CoPipeSEff i o zz a -> + CoPipe (Cid, i) o (Eff zz) a -> + CoPipe (Cid, i) o (Eff zz) a +(+|) l r = eitherCoPipe split l' r + where + l' = mapCoPipe (\(_ :: Cid, potato) -> potato) id id (toCoPipe l) + +split :: (Cid, i) -> Either (Cid, i) (Cid, i) +split (Cid 0, potato) = Left (Cid 0, potato) +split (Cid c, potato) = Right (Cid (c-1), potato) + +testCoroutine :: TestTree +testCoroutine = testGroup "Coroutine" + [ testCase "feedPipe-sum" $ runPureEff (feedPipe [1,2,3] (toPipe cumulSum)) @?= [0,1,3,6] + , testCase "feedCoroutine-sum" $ runPureEff (feedCoroutine [1,2,3] cumulSum) @?= [0,1,3,6] + , testCase "filterEven" $ runPureEff filterEvenResult @?= [4,2] + , testCase "pingpong" $ runPureEff pingpong @?= "pingpongdingdongbingbong" + , testCase "echo" $ runPureEff echo @?= "S-LL-LR-RL-RR-LL-RL-LR-RR" + , testCase "hotpotato" $ runPureEff hotpotatoes @?= Cid 1 + ] + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ testState + , testException + , testNonDet + , testCoroutine + ]