diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for bluefin-algae + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/bench/quadratic-counter.hs b/bench/quadratic-counter.hs new file mode 100644 --- /dev/null +++ b/bench/quadratic-counter.hs @@ -0,0 +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 ] diff --git a/bluefin-algae.cabal b/bluefin-algae.cabal new file mode 100644 --- /dev/null +++ b/bluefin-algae.cabal @@ -0,0 +1,74 @@ +cabal-version: 3.4 +name: bluefin-algae +version: 0.1.0.0 +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 +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 diff --git a/src/Bluefin/Algae.hs b/src/Bluefin/Algae.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae.hs @@ -0,0 +1,182 @@ +{-# 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)) +-- @ diff --git a/src/Bluefin/Algae/Coroutine.hs b/src/Bluefin/Algae/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/Coroutine.hs @@ -0,0 +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 diff --git a/src/Bluefin/Algae/DelCont.hs b/src/Bluefin/Algae/DelCont.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/DelCont.hs @@ -0,0 +1,186 @@ +{-# 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) diff --git a/src/Bluefin/Algae/DynExn.hs b/src/Bluefin/Algae/DynExn.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/DynExn.hs @@ -0,0 +1,86 @@ +{-# 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) diff --git a/src/Bluefin/Algae/Exception.hs b/src/Bluefin/Algae/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/Exception.hs @@ -0,0 +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) diff --git a/src/Bluefin/Algae/Exception/DynExn.hs b/src/Bluefin/Algae/Exception/DynExn.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/Exception/DynExn.hs @@ -0,0 +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) diff --git a/src/Bluefin/Algae/NonDeterminism.hs b/src/Bluefin/Algae/NonDeterminism.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/NonDeterminism.hs @@ -0,0 +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 diff --git a/src/Bluefin/Algae/Reader.hs b/src/Bluefin/Algae/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/Reader.hs @@ -0,0 +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 diff --git a/src/Bluefin/Algae/State.hs b/src/Bluefin/Algae/State.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Algae/State.hs @@ -0,0 +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 diff --git a/src/Bluefin/Exception/Dynamic.hs b/src/Bluefin/Exception/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Exception/Dynamic.hs @@ -0,0 +1,85 @@ +{-# 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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +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 + ]