packages feed

bluefin-algae (empty) → 0.1.0.0

raw patch · 15 files changed

+1824/−0 lines, 15 filesdep +basedep +bluefindep +bluefin-algae

Dependencies added: base, bluefin, bluefin-algae, bluefin-internal, tasty, tasty-bench, tasty-hunit

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for bluefin-algae++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ bench/quadratic-counter.hs view
@@ -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 ]
+ bluefin-algae.cabal view
@@ -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
+ src/Bluefin/Algae.hs view
@@ -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+--+-- - <https://homepages.inf.ed.ac.uk/gdp/publications/handling-algebraic-effects.pdf Handling Algebraic Effects> (2013) by Gordon D. Plotkin and Matija Pretnar.+-- - <https://www.microsoft.com/en-us/research/uploads/prod/2021/05/namedh-tr.pdf First-class names for effect handlers> (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))+-- @
+ src/Bluefin/Algae/Coroutine.hs view
@@ -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.+--+-- - <https://en.wikipedia.org/wiki/Coroutine Coroutine> and+--   <https://en.wikipedia.org/wiki/Generator_(computer_programming) Generator>+--   on Wikipedia+-- - <https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Statements/function*#description Generators in Javascript>+-- - <https://docs.python.org/3/reference/expressions.html#yieldexpr Generators in Python>+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
+ src/Bluefin/Algae/DelCont.hs view
@@ -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+--+-- - <https://ghc-proposals.readthedocs.io/en/latest/proposals/0313-delimited-continuation-primops.html Delimited continuation primops> (GHC proposal, implemented in GHC 9.6.1).+-- - <https://homes.luddy.indiana.edu/ccshan/recur/recur.pdf Shift to Control> (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)
+ src/Bluefin/Algae/DynExn.hs view
@@ -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)
+ src/Bluefin/Algae/Exception.hs view
@@ -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)
+ src/Bluefin/Algae/Exception/DynExn.hs view
@@ -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)
+ src/Bluefin/Algae/NonDeterminism.hs view
@@ -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
+ src/Bluefin/Algae/Reader.hs view
@@ -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
+ src/Bluefin/Algae/State.hs view
@@ -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
+ src/Bluefin/Exception/Dynamic.hs view
@@ -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)
+ test/Main.hs view
@@ -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+  ]