bluefin-internal 0.6.0.0 → 0.11.0.0
raw patch · 20 files changed
Files
- CHANGELOG.md +77/−0
- bluefin-internal.cabal +11/−7
- src/Bluefin/Internal.hs +349/−213
- src/Bluefin/Internal/Capability/ThrowCatch.hs +88/−0
- src/Bluefin/Internal/CloneableHandle.hs +31/−31
- src/Bluefin/Internal/DslBuilder.hs +4/−8
- src/Bluefin/Internal/DslBuilderEff.hs +31/−6
- src/Bluefin/Internal/DslBuilderEffects.hs +0/−48
- src/Bluefin/Internal/Examples.hs +4/−1083
- src/Bluefin/Internal/Exception.hs +2/−2
- src/Bluefin/Internal/Exception/Scoped.hs +6/−1
- src/Bluefin/Internal/GadtEffect.hs +5/−5
- src/Bluefin/Internal/OneWayCoercible.hs +25/−0
- src/Bluefin/Internal/Pipes.hs +0/−285
- src/Bluefin/Internal/Prim.hs +12/−7
- src/Bluefin/Internal/Vault.hs +44/−0
- test/Main.hs +117/−19
- test/Test/RunPureEff.hs +144/−0
- test/Test/SpecH.hs +17/−0
- test/Test/ThrowCatch.hs +29/−0
CHANGELOG.md view
@@ -1,3 +1,80 @@+# 0.11.0.0++* Add `Bluefin.Internal.Capability.ThrowCatch`++* Add `ThrowCatch`, `throwCatchThrow`, `throwCatchTry`++* Remove `withScopedException_`++* Add `Bluefin.Internal.DslBuilderEff.runDslBuilderEffMappedArgs`++* Remove `Bluefin.Internal.DslBuilderEffects`++# 0.10.1.0++* Add `runPureEffAsyncSafe` and `runPureEffAsyncSafeRestarting`++* Use `INLINE [0]` on `runDslBuilderEff` for improved performance++# 0.10.0.0++* Make `Ask`, `AskCapability`, `Await`, `JumpTo`, `Modify`, `Request`,+ `ReturnEarly`, `Tell`, `Throw`, and `Yield` the canonical capability+ types; `Reader`, `HandleReader`, `Consume`, `Jump`, `State`, `Coroutine`,+ `EarlyReturn`, `Writer`, `Exception`, and `Stream` are now type synonyms.++* Move `Bluefin.Internal.Pipes` to `bluefin-examples`++* Remove unused failing stubs `connect` and `head'` from+ `Bluefin.Internal`++* Breaking change: separate `Prim`'s primitive state and capability+ scope type parameters++# 0.9.2.0++* Bug fix: release `Reader` Vault keys when their handler scope exits.++* Make `Vault`'s `Key` type role representational. This is+ technically a PVP violation but since it's fixing a type safety bug+ we're not going to release a major version for it.++# 0.9.1.0++* Add `yieldToPureList`++# 0.9.0.0++* Add quantified constraint `forall e es. (e <: es) => OneWayCoercible+ (h e) (h es)` as a superclass of `Handle h`++* Improve performance of `mapHandle` by using `unsafeOneWayCoerce`.+ This can violate type safety if a `OneWayCoercibleInstance` is+ invalid, so do not define or use invalid `OneWayCoercible`+ instances!++# 0.8.2.0++* Improve performance of `Reader` and `DslBuilderEff`++# 0.8.1.0++* Add `trans3D`, `oneWayCoercibleNewtypeHandle`++# 0.8.0.0++* Restrict `Reader` type tag to `Effects`++* Move most of `Bluefin.Internal.Examples`, `zipCoroutines` and+ `mapStream` to `Bluefin.Examples`++# 0.7.0.0++* Fix `Reader` bug that caused incorrect scoping in+ `awaitYield`/`connectRequests`/`streamConsume`/`connectCoroutines`++ <https://github.com/tomjaguarpaw/bluefin/issues/98>+ # 0.6.0.0 * Changed type of `runEff` to match `runEff_`
bluefin-internal.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: bluefin-internal-version: 0.6.0.0+version: 0.11.0.0 license: MIT license-file: LICENSE author: Tom Ellis@@ -77,27 +77,28 @@ hs-source-dirs: src build-depends: async >= 2.2 && < 2.3,- base >= 4.14 && < 4.23,+ base >= 4.15 && < 4.23, unliftio-core < 0.3, primitive >= 0.8 && < 0.10, transformers < 0.7, transformers-base < 0.5,- monad-control < 1.1+ monad-control < 1.1,+ vault >= 0.3 && < 0.4 exposed-modules: Bluefin.Internal, Bluefin.Internal.CloneableHandle, Bluefin.Internal.DslBuilder, Bluefin.Internal.DslBuilderEff,- Bluefin.Internal.DslBuilderEffects, Bluefin.Internal.Examples, Bluefin.Internal.Exception,+ Bluefin.Internal.Capability.ThrowCatch, Bluefin.Internal.Exception.Scoped, Bluefin.Internal.GadtEffect, Bluefin.Internal.Key, Bluefin.Internal.OneWayCoercible,- Bluefin.Internal.Pipes, Bluefin.Internal.Prim,- Bluefin.Internal.System.IO+ Bluefin.Internal.System.IO,+ Bluefin.Internal.Vault test-suite bluefin-test import: defaults@@ -106,7 +107,10 @@ hs-source-dirs: test main-is: Main.hs other-modules: Test.GeneralBracket,- Test.SpecH+ Test.RunPureEff,+ Test.SpecH,+ Test.ThrowCatch build-depends: base,+ async, bluefin-internal
src/Bluefin/Internal.hs view
@@ -16,13 +16,20 @@ import Bluefin.Internal.OneWayCoercible ( OneWayCoercible (oneWayCoercibleImpl), OneWayCoercibleD,+ OneWayCoercion, gOneWayCoercible,- oneWayCoerce, oneWayCoercible,+ oneWayCoercion,+ trans3D,+ unsafeCoercionOfOneWayCoercion,+ unsafeOneWayCoerce, unsafeOneWayCoercible, )+import Bluefin.Internal.Vault (Vault)+import Bluefin.Internal.Vault qualified as Vault+import Control.Concurrent (forkIO, forkIOWithUnmask, killThread, myThreadId, throwTo) import Control.Concurrent.Async qualified as Async-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar, takeMVar) import Control.Exception qualified import Control.Monad (forever) import Control.Monad.Base (MonadBase (liftBase))@@ -30,16 +37,20 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM)+import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Reader qualified as Reader-import Data.Coerce (coerce)+import Data.Coerce (Coercible, coerce) import Data.Foldable (for_)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Function (fix)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.Kind (Type) import Data.Proxy (Proxy (Proxy)) import Data.Type.Coercion (Coercion (Coercion))-import GHC.Exts (Any, Proxy#, proxy#)+import GHC.Exts (Any, Proxy#, keepAlive#, proxy#) import GHC.Generics (Generic, M1, Rec1, (:*:))+import GHC.IO (IO (..)) import System.IO.Unsafe (unsafePerformIO)+import System.Mem.Weak (addFinalizer) import Unsafe.Coerce (unsafeCoerce) import Prelude hiding (drop, head, read, return) @@ -55,14 +66,16 @@ type (:&) = Union -newtype Eff (es :: Effects) a = UnsafeMkEff {unsafeUnEff :: IO a}+type Env = IORef Vault++newtype Eff (es :: Effects) a = UnsafeMkEff {unsafeUnEff :: Env -> IO a} deriving stock (Functor)- deriving newtype (Applicative, Monad, MonadFix)+ deriving (Applicative, Monad, MonadFix) via ReaderT Env IO type role Eff nominal representational instance (e <: es) => OneWayCoercible (Eff e) (Eff es) where- oneWayCoercibleImpl = oneWayCoercible+ oneWayCoercibleImpl = unsafeOneWayCoercible instance (e <: es) => OneWayCoercible (Eff e r) (Eff es r) where oneWayCoercibleImpl = oneWayCoercible@@ -89,7 +102,7 @@ ((forall r. (forall e1. IOE e1 -> Eff (e1 :& es) r) -> IO r) -> IO a) -> IOE e2 -> Eff es a-withEffToIO k io = effIO io (k (\f -> unsafeUnEff (f io)))+withEffToIO k io = UnsafeMkEff (\env -> k (\f -> unsafeUnEff (f io) env)) withEffToIO' :: (e2 <: es) =>@@ -142,15 +155,24 @@ Eff es a race x y io = do r <- withEffToIO' io $ \toIO ->- Async.race (toIO x) (toIO y)+ Async.race (toIO (withClonedEnv . x)) (toIO (withClonedEnv . y)) pure $ case r of Left a -> a Right a -> a +withClonedEnv :: Eff es r -> Eff es r+withClonedEnv m = UnsafeMkEff $ \vault -> do+ vault' <- cloneIORef vault+ case m of UnsafeMkEff m' -> m' vault'+ where+ cloneIORef ref = do+ orig <- readIORef ref+ newIORef orig+ -- | Connect two coroutines. Their execution is interleaved by--- exchanging @a@s and @b@s. When the first yields its first @a@ it--- starts the second (which is awaiting an @a@).+-- exchanging @a@s and @b@s. When the former yields its first @a@ it+-- starts the latter (which is awaiting an @a@). connectCoroutines :: forall es a b r. (forall e. Coroutine a b e -> Eff (e :& es) r) ->@@ -200,24 +222,6 @@ Eff es r streamConsume s c = consumeStream c s -zipCoroutines ::- (e1 <: es) =>- Coroutine (a1, a2) b e1 ->- (forall e. Coroutine a1 b e -> Eff (e :& es) r) ->- (forall e. Coroutine a2 b e -> Eff (e :& es) r) ->- -- | ͘- Eff es r-zipCoroutines c m1 m2 = do- connectCoroutines m1 $ \a1 c1 -> do- connectCoroutines (useImplUnder . m2) $ \a2 c2 -> do- evalState (a1, a2) $ \ass -> do- forever $ do- as <- get ass- b' <- yieldCoroutine c as- a1' <- yieldCoroutine c1 b'- a2' <- yieldCoroutine c2 b'- put ass (a1', a2')- instance (e <: es) => MonadBase IO (EffReader (IOE e) es) where liftBase = liftIO @@ -226,7 +230,7 @@ liftBaseWith = withRunInIO restoreM = pure -instance (e <: es) => MonadFail (EffReader (Exception String e) es) where+instance (e <: es) => MonadFail (EffReader (Throw String e) es) where fail = MkEffReader . flip throw hoistReader ::@@ -267,8 +271,8 @@ -- `Either String` and then applying `either (throw f) pure`. withMonadFail :: (e <: es) =>- -- | @Exception@ to @throw@ on @fail@- Exception String e ->+ -- | @Throw@ to @throw@ on @fail@+ Throw String e -> -- | 'MonadFail' operation (forall m. (MonadFail m) => m r) -> -- | @MonadFail@ operation run in @Eff@@@ -277,13 +281,95 @@ -- | Run an 'Eff' that doesn't contain any unhandled effects. runPureEff :: (forall es. Eff es a) -> a-runPureEff e = unsafePerformIO (runEff (\_ -> e))+runPureEff = runPureEffPoisonable +-- | Run an 'Eff' that doesn't contain any unhandled effects. If the+-- evaluation of the result of runPureEffPoisonable is interrupted by+-- an asynchronous exception the thunk can become poisoned and unable+-- to be resumed (subsequent evaluation throws the async exception+-- again).+--+-- See https://github.com/tomjaguarpaw/bluefin/issues/30+runPureEffPoisonable :: (forall es. Eff es a) -> a+runPureEffPoisonable e = unsafePerformIO (runEff (\_ -> e))++-- | Run an 'Eff' that doesn't contain any unhandled effects. The+-- computation runs in a dedicated worker thread, so an asynchronous+-- exception received by a thread demanding the result does not+-- interrupt the computation itself. (An exception delivered to the+-- worker thread would be rethrown and could poison the thunk, but+-- that cannot happen unless the worker thread's ID is looked up by+-- some out-of-band means -- don't do that!).+--+-- The worker thread continues to work even if the thread forcing it+-- is killed, which may be surprising. If no references to the thunk+-- for the result of runPureEffAsyncSafe remain, the worker thread is+-- killed.+--+-- A proper fix to this issue probably belongs in GHC.+runPureEffAsyncSafe :: (forall es. Eff es a) -> a+runPureEffAsyncSafe e = unsafePerformIO $ do+ result <- newEmptyMVar+ owner <- newIORef ()+ _ <- Control.Exception.mask_ $ forkIOWithUnmask $ \unmask -> do+ tid <- myThreadId+ addFinalizer owner (killThread tid)+ r <- Control.Exception.try @Control.Exception.SomeException . unmask $ do+ runEff (\_ -> e)+ putMVar result r+ r <- keepAlive owner (readMVar result)+ either Control.Exception.throwIO pure r++keepAlive :: a -> IO b -> IO b+keepAlive a (IO action) = IO $ \s -> keepAlive# a s action++-- | Like 'runPureEffAsyncSafe', but starts a fresh worker after an+-- asynchronous exception interrupts a demand for the result. This+-- means that if the thread forcing the thunk is killed the work done+-- so far is discarded, and restarted from scratch in the next+-- evaluation.+--+-- This should not be used. It exists only as an example of a (worse)+-- alternative approach. Use 'runPureEffAsyncSafe' instead.+runPureEffAsyncSafeRestarting :: (forall es. Eff es a) -> a+runPureEffAsyncSafeRestarting effBody = unsafePerformIO $+ Control.Exception.mask $ \restore -> do+ tidVar <- newEmptyMVar+ done <- newEmptyMVar++ let body = do+ tid <- forkIO $ do+ r <-+ Control.Exception.try @Control.Exception.SomeException $+ restore $+ runEff (\_ -> effBody)+ putMVar done r+ putMVar tidVar tid+ takeMVar done++ r <- fix $ \again -> do+ attempted <-+ restore $+ Control.Exception.try @Control.Exception.SomeException body+ case attempted of+ Left ex -> do+ tid <- takeMVar tidVar+ killThread tid+ _ <- takeMVar done+ myself <- myThreadId+ throwTo myself ex+ again+ Right result -> pure result++ case r of+ Left l -> Control.Exception.throwIO l+ Right r' -> pure r'+ unsafeCoerceEff :: Eff t r -> Eff t' r unsafeCoerceEff = coerce weakenEff :: t `In` t' -> Eff t r -> Eff t' r-weakenEff _ = unsafeCoerceEff+weakenEff (In# (# #)) = unsafeCoerceEff insertFirst :: Eff b r -> Eff (c1 :& b) r insertFirst = weakenEff (drop (eq ZW))@@ -346,41 +432,55 @@ type role StateSource nominal -- | Capability to throw an exception of type @exn@-newtype Exception exn (e :: Effects)+newtype Throw exn (e :: Effects) = MkException (forall a. exn -> Eff e a)- deriving (Handle) via OneWayCoercibleHandle (Exception exn)+ deriving (Handle) via OneWayCoercibleHandle (Throw exn) -type role Exception representational nominal+type role Throw representational nominal -instance (e <: es) => OneWayCoercible (Exception ex e) (Exception ex es) where+instance (e <: es) => OneWayCoercible (Throw ex e) (Throw ex es) where oneWayCoercibleImpl = oneWayCoercible +-- | A scoped exception capability that can catch within its own scope.+type ThrowCatch :: Type -> Effects -> Type+newtype ThrowCatch ex e+ = MkThrowCatch (ScopedException.Exception ex)+ deriving (Handle) via OneWayCoercibleHandle (ThrowCatch ex)++type role ThrowCatch nominal nominal++instance+ (e <: es) =>+ OneWayCoercible (ThrowCatch ex e) (ThrowCatch ex es)+ where+ oneWayCoercibleImpl = unsafeOneWayCoercible+ -- | Capability to modify a reference to an @s@-newtype State s (e :: Effects) = UnsafeMkState (IORef s)- deriving (Handle) via OneWayCoercibleHandle (State s)+newtype Modify s (e :: Effects) = UnsafeMkState (IORef s)+ deriving (Handle) via OneWayCoercibleHandle (Modify s) -type role State representational nominal+type role Modify representational nominal -instance (e <: es) => OneWayCoercible (State s e) (State s es) where+instance (e <: es) => OneWayCoercible (Modify s e) (Modify s es) where oneWayCoercibleImpl = oneWayCoercible -- | Capability to yield a value of type @a@ and then await a value of -- type @b@ in response.-newtype Coroutine a b (e :: Effects) = MkCoroutine (a -> Eff e b)- deriving (Handle) via OneWayCoercibleHandle (Coroutine a b)+newtype Request a b (e :: Effects) = MkCoroutine (a -> Eff e b)+ deriving (Handle) via OneWayCoercibleHandle (Request a b) -instance (e <: es) => OneWayCoercible (Coroutine a b e) (Coroutine a b es) where+instance (e <: es) => OneWayCoercible (Request a b e) (Request a b es) where oneWayCoercibleImpl = oneWayCoercible -- | Capability to yield values of type @a@. It is implemented as a -- 'Bluefin.Capability.Request' capability that can yield values of -- type @a@ and then await values of type @()@.-type Stream a = Coroutine a ()+type Yield a = Request a () -type Consume a = Coroutine () a+type Await a = Request () a -- | Every Bluefin capability should have an instance of class @Handle@.--- Built-in capabilities, such as 'Exception', 'State' and 'IOE', come with+-- Built-in capabilities, such as 'Throw', 'Modify' and 'IOE', come with -- @Handle@ instances. -- -- You should define a @Handle@ instance for each capability that you@@ -392,8 +492,8 @@ -- @ -- data Application e = MkApplication -- { queryDatabase :: String -> Int -> Eff e [String],--- applicationState :: State (Int, Bool) e,--- logger :: Stream String e+-- applicationState :: Modify (Int, Bool) e,+-- logger :: Yield String e -- } -- deriving (Generic) -- deriving (Handle) via 'OneWayCoercibleHandle' Application@@ -412,7 +512,10 @@ -- -- Please note the "handle" nomeclature is legacy and will probably -- change to "capability" in the future. See "Bluefin.Capability".-class Handle (h :: Effects -> Type) where+class+ (forall e es. (e <: es) => OneWayCoercible (h e) (h es)) =>+ Handle (h :: Effects -> Type)+ where handleImpl :: HandleD h -- | This was previously a method of class 'Handle' using which you@@ -444,7 +547,7 @@ -- oneWayCoercibleImpl = 'oneWayCoercibleTrustMe' $ \\h -> \<mapHandle definition\> -- @ mapHandle :: forall h e es. (Handle h, e <: es) => h e -> h es-mapHandle = case handleDictImpl @h of MkHandleDict -> oneWayCoerce+mapHandle = unsafeOneWayCoerce withHandle :: forall h r.@@ -452,7 +555,7 @@ -- | ͘ ((forall e es. (e <: es) => OneWayCoercible (h e) (h es)) => r) -> r-withHandle r = case handleDictImpl @h of MkHandleDict -> r+withHandle r = r type HandleDict :: (Effects -> Type) -> Type data HandleDict h where@@ -514,13 +617,13 @@ handleOneWayCoercible = MkHandleD (unsafeCoerce (MkHandleDict @h)) instance (Handle h) => Handle (Rec1 h) where- handleImpl = withHandle @h handleOneWayCoercible+ handleImpl = handleOneWayCoercible instance (Handle h) => Handle (M1 i t h) where- handleImpl = withHandle @h handleOneWayCoercible+ handleImpl = handleOneWayCoercible instance (Handle h1, Handle h2) => Handle (h1 :*: h2) where- handleImpl = withHandle @h1 (withHandle @h2 handleOneWayCoercible)+ handleImpl = handleOneWayCoercible -- | It is not always possible to derive an instance of -- 'OneWayCoercible'. In such cases write a definition of@@ -580,6 +683,30 @@ -- } +-- | For defining 'OneWayCoercible' instances for newtypes. Example:+--+-- @+-- newtype Random g e = Random (Modify g e)+-- deriving (Handle) via OneWayCoercibleHandle (Random g)+--+-- instance (e \<: es) => OneWayCoercible (Random g e) (Random g es) where+-- oneWayCoercibleImpl = oneWayCoercibleNewtypeHandle @(Modify g)+-- @+oneWayCoercibleNewtypeHandle ::+ forall h1 h2 e es.+ (e :> es) =>+ ( Coercible (h2 e) (h1 e),+ OneWayCoercible (h1 e) (h1 es),+ Coercible (h1 es) (h2 es)+ ) =>+ -- | ͘+ OneWayCoercibleD (h2 e) (h2 es)+oneWayCoercibleNewtypeHandle =+ trans3D+ (oneWayCoercible @(h2 e) @(h1 e))+ (oneWayCoercibleImpl @(h1 e) @(h1 es))+ (oneWayCoercible @(h1 es) @(h2 es))+ -- | A convenience type whose only purpose is to avoid writing @(# #)@ -- as an argument to functions which are only functions because -- top-level definitions of unlifted kind are forbidden.@@ -728,12 +855,20 @@ -- @ throw :: (e <: es) =>- Exception ex e ->+ Throw ex e -> -- | Value to throw ex -> Eff es a throw h = case mapHandle h of MkException throw_ -> throw_ +throwCatchThrow ::+ (e <: es) =>+ ThrowCatch ex e ->+ ex ->+ Eff es a+throwCatchThrow (MkThrowCatch ex) exn =+ unsafeProvideIO $ \io -> effIO io (ScopedException.throw ex exn)+ has :: forall a b. (a <: b) => a `In` b -- This is safe because, as shown by instanceProof1/2/3, the only way -- to construct `a <: b` is if `a `In` b`.@@ -758,14 +893,21 @@ -- @ try :: forall exn (es :: Effects) a.- (forall e. Exception exn e -> Eff (e :& es) a) ->+ (forall e. Throw exn e -> Eff (e :& es) a) -> -- | @Left@ if the exception was thrown, @Right@ otherwise Eff es (Either exn a) try f =+ throwCatchTry $ \ex ->+ f (MkException (throwCatchThrow ex))++throwCatchTry ::+ (forall e. ThrowCatch ex e -> Eff (e :& es) a) ->+ Eff es (Either ex a)+throwCatchTry f = unsafeProvideIO $ \io -> do withEffToIO_ io $ \effToIO -> do- withScopedException_ $ \throw_ -> do- effToIO (f (MkException (effIO io . throw_)))+ ScopedException.try $ \ex -> do+ effToIO (f (MkThrowCatch ex)) -- | -- @@@ -778,7 +920,7 @@ forall exn (es :: Effects) a. -- | If the exception is thrown, apply this handler (exn -> Eff es a) ->- (forall e. Exception exn e -> Eff (e :& es) a) ->+ (forall e. Throw exn e -> Eff (e :& es) a) -> Eff es a handle h f = try f >>= \case@@ -788,7 +930,7 @@ -- | 'handle', but with the argument order swapped catch :: forall exn (es :: Effects) a.- (forall e. Exception exn e -> Eff (e :& es) a) ->+ (forall e. Throw exn e -> Eff (e :& es) a) -> -- | If the exception is thrown, apply this handler (exn -> Eff es a) -> Eff es a@@ -828,7 +970,7 @@ forall ex es e1 e2 r. (e1 <: es, e2 <: es, Control.Exception.Exception ex) => IOE e1 ->- Exception ex e2 ->+ Throw ex e2 -> Eff es r -> -- | ͘ Eff es r@@ -895,7 +1037,7 @@ withStateInIO :: (e1 <: es, e2 <: es) => IOE e1 ->- State s e2 ->+ Modify s e2 -> (IORef s -> IO r) -> Eff es r withStateInIO io (UnsafeMkState r) k = effIO io (k r)@@ -909,7 +1051,7 @@ -- @ get :: (e <: es) =>- State s e ->+ Modify s e -> -- | The current value of the state Eff es s get st = unsafeProvideIO $ \io -> withStateInIO io st readIORef@@ -923,7 +1065,7 @@ -- @ put :: (e <: es) =>- State s e ->+ Modify s e -> -- | The new value of the state. The new value is forced before -- writing it to the state. s ->@@ -938,7 +1080,7 @@ -- @ modify :: (e <: es) =>- State s e ->+ Modify s e -> -- | Apply this function to the state. The new value of the state -- is forced before writing it to the state. (s -> s) ->@@ -947,20 +1089,16 @@ s <- get state put state (f s) -withScopedException_ :: ((forall a. e -> IO a) -> IO r) -> IO (Either e r)-withScopedException_ f =- ScopedException.try (\ex -> f (ScopedException.throw ex))- -- | -- @ -- 'runPureEff' $ 'withStateSource' $ \\source -> do -- n <- 'newState' source 5 -- total <- newState source 0 ----- 'withJump' $ \\done -> forever $ do--- n' <- 'Bluefin.State.get' n--- 'Bluefin.State.modify' total (+ n')--- when (n' == 0) $ 'Bluefin.Jump.jumpTo' done+-- 'withJumpTo' $ \\done -> forever $ do+-- n' <- 'Bluefin.Capability.Modify.get' n+-- 'Bluefin.Capability.Modify.modify' total (+ n')+-- when (n' == 0) $ 'Bluefin.Capability.JumpTo.jumpTo' done -- modify n (subtract 1) -- -- get total@@ -978,10 +1116,10 @@ -- n <- 'newState' source 5 -- total <- newState source 0 ----- 'Bluefin.Jump.withJump' $ \\done -> forever $ do--- n' <- 'Bluefin.State.get' n--- 'Bluefin.State.modify' total (+ n')--- when (n' == 0) $ 'Bluefin.Jump.jumpTo' done+-- 'Bluefin.Capability.JumpTo.withJumpTo' $ \\done -> forever $ do+-- n' <- 'Bluefin.Capability.Modify.get' n+-- 'Bluefin.Capability.Modify.modify' total (+ n')+-- when (n' == 0) $ 'Bluefin.Capability.JumpTo.jumpTo' done -- modify n (subtract 1) -- -- get total@@ -993,7 +1131,7 @@ -- | The initial value for the state capability s -> -- | A new state capability- Eff es (State s e)+ Eff es (Modify s e) newState StateSource s = unsafeProvideIO $ \io -> do fmap UnsafeMkState (effIO io (newIORef s)) @@ -1008,7 +1146,7 @@ -- | Initial state s -> -- | Stateful computation- (forall e. State s e -> Eff (e :& es) a) ->+ (forall e. Modify s e -> Eff (e :& es) a) -> -- | Result and final state Eff es (a, s) runState s f = do@@ -1039,7 +1177,7 @@ -- @ yield :: (e1 <: es) =>- Stream a e1 ->+ Yield a e1 -> -- | Yield this value from the stream a -> Eff es ()@@ -1066,7 +1204,7 @@ -- ([0, 0, 1, 10, 2, 20, 3, 30], ()) -- @ forEach ::- (forall e1. Coroutine a b e1 -> Eff (e1 :& es) r) ->+ (forall e1. Request a b e1 -> Eff (e1 :& es) r) -> -- | Apply this effectful function for each element of the coroutine (a -> Eff es b) -> Eff es r@@ -1100,7 +1238,7 @@ (Foldable t, e1 <: es) => -- | Yield all these values from the stream t a ->- Stream a e1 ->+ Yield a e1 -> Eff es () inFoldable t = for_ t . yield @@ -1114,8 +1252,8 @@ enumerate :: (e2 <: es) => -- | ͘- (forall e1. Stream a e1 -> Eff (e1 :& es) r) ->- Stream (Int, a) e2 ->+ (forall e1. Yield a e1 -> Eff (e1 :& es) r) ->+ Yield (Int, a) e2 -> Eff es r enumerate s = enumerateFrom 0 s @@ -1130,8 +1268,8 @@ (e2 <: es) => -- | Initial value Int ->- (forall e1. Stream a e1 -> Eff (e1 :& es) r) ->- Stream (Int, a) e2 ->+ (forall e1. Yield a e1 -> Eff (e1 :& es) r) ->+ Yield (Int, a) e2 -> Eff es r enumerateFrom n ss st = evalState n $ \i -> forEach (useImplUnder . ss) $ \s -> do@@ -1153,10 +1291,10 @@ Eff es r consumeEach k e = forEach k (\() -> e) -await :: (e <: es) => Consume a e -> Eff es a+await :: (e <: es) => Await a e -> Eff es a await r = yieldCoroutine r () -type EarlyReturn = Exception+type ReturnEarly = Throw -- | Run an 'Eff' action with the ability to return early to this -- point. In the language of exceptions, 'withEarlyReturn' installs@@ -1187,7 +1325,7 @@ -- @ returnEarly :: (e <: es) =>- EarlyReturn r e ->+ ReturnEarly r e -> -- | Return early to the handler, with this value. r -> Eff es a@@ -1204,7 +1342,7 @@ -- | Initial state s -> -- | Stateful computation- (forall e. State s e -> Eff (e :& es) a) ->+ (forall e. Modify s e -> Eff (e :& es) a) -> -- | Result Eff es a evalState s f = fmap fst (runState s f)@@ -1220,7 +1358,7 @@ -- | Initial state s -> -- | Stateful computation- (forall e. State s e -> Eff (e :& es) (s -> a)) ->+ (forall e. Modify s e -> Eff (e :& es) (s -> a)) -> -- | Result Eff es a withState s f = do@@ -1273,10 +1411,10 @@ Eff es r withC2 c f = withCompound c (\_ i -> f i) -putC :: forall ss es e. (ss <: es) => Compound e (State Int) ss -> Int -> Eff es ()+putC :: forall ss es e. (ss <: es) => Compound e (Modify Int) ss -> Int -> Eff es () putC c i = withC2 c (\h -> put h i) -getC :: forall ss es e. (ss <: es) => Compound e (State Int) ss -> Eff es Int+getC :: forall ss es e. (ss <: es) => Compound e (Modify Int) ss -> Eff es Int getC c = withC2 c (\h -> get h) -- TODO: Make this (s1 <: es, s2 <: es), like withC@@ -1300,13 +1438,19 @@ -- ([1,2,100], ()) -- @ yieldToList ::- (forall e1. Stream a e1 -> Eff (e1 :& es) r) ->+ (forall e1. Yield a e1 -> Eff (e1 :& es) r) -> -- | Yielded elements and final result Eff es ([a], r) yieldToList f = do (as, r) <- yieldToReverseList f pure (reverse as, r) +-- | Gather all yielded elements into a list, purely. Can be used+-- when only when there are no other capabilities in scope, besides+-- the 'Yield'.+yieldToPureList :: (forall e. Yield a e -> Eff e r) -> ([a], r)+yieldToPureList f = runPureEff $ yieldToList $ \y -> useImpl (f y)+ -- | -- @ -- >>> runPureEff $ withYieldToList $ \\y -> do@@ -1317,8 +1461,8 @@ -- 3 -- @ withYieldToList ::- -- | Stream computation- (forall e. Stream a e -> Eff (e :& es) ([a] -> r)) ->+ -- | Yield computation+ (forall e. Yield a e -> Eff (e :& es) ([a] -> r)) -> -- | Result Eff es r withYieldToList f = do@@ -1337,34 +1481,24 @@ -- ([100,2,1], ()) -- @ yieldToReverseList ::- (forall e. Stream a e -> Eff (e :& es) r) ->+ (forall e. Yield a e -> Eff (e :& es) r) -> -- | Yielded elements in reverse order, and final result Eff es ([a], r) yieldToReverseList f = do- evalState [] $ \(s :: State lo st) -> do+ evalState [] $ \(s :: Modify lo st) -> do r <- forEach (useImplUnder . f) $ \i -> modify s (i :) as <- get s pure (as, r) -mapStream ::- (e2 <: es) =>- -- | Apply this function to all elements of the input stream.- (a -> b) ->- -- | Input stream- (forall e1. Stream a e1 -> Eff (e1 :& es) r) ->- Stream b e2 ->- Eff es r-mapStream f = mapMaybe (Just . f)- mapMaybe :: (e2 <: es) => -- | Yield from the output stream all of the elemnts of the input -- stream for which this function returns @Just@ (a -> Maybe b) -> -- | Input stream- (forall e1. Stream a e1 -> Eff (e1 :& es) r) ->- Stream b e2 ->+ (forall e1. Yield a e1 -> Eff (e1 :& es) r) ->+ Yield b e2 -> Eff es r mapMaybe f s y = forEach s $ \a -> do case f a of@@ -1375,8 +1509,8 @@ catMaybes :: (e2 <: es) => -- | Input stream- (forall e1. Stream (Maybe a) e1 -> Eff (e1 :& es) r) ->- Stream a e2 ->+ (forall e1. Yield (Maybe a) e1 -> Eff (e1 :& es) r) ->+ Yield a e2 -> Eff es r catMaybes s y = mapMaybe id s y @@ -1391,7 +1525,7 @@ cycleToStream :: (Foldable f, e1 <: es) => f a ->- Stream a e1 ->+ Yield a e1 -> -- | ͘ Eff es () cycleToStream f y = do@@ -1419,7 +1553,7 @@ await source >>= yield sink loop (c - 1) -type Jump = EarlyReturn ()+type JumpTo = ReturnEarly () -- | -- @@@ -1427,10 +1561,10 @@ -- n <- 'newState' source 5 -- total <- newState source 0 ----- 'Bluefin.Jump.withJump' $ \\done -> forever $ do--- n' <- 'Bluefin.State.get' n--- 'Bluefin.State.modify' total (+ n')--- when (n' == 0) $ 'Bluefin.Jump.jumpTo' done+-- 'Bluefin.Capability.JumpTo.withJumpTo' $ \\done -> forever $ do+-- n' <- 'Bluefin.Capability.Modify.get' n+-- 'Bluefin.Capability.Modify.modify' total (+ n')+-- when (n' == 0) $ 'Bluefin.Capability.JumpTo.jumpTo' done -- modify n (subtract 1) -- -- get total@@ -1448,10 +1582,10 @@ -- n <- 'newState' source 5 -- total <- newState source 0 ----- 'Bluefin.Jump.withJump' $ \\done -> forever $ do--- n' <- 'Bluefin.State.get' n--- 'Bluefin.State.modify' total (+ n')--- when (n' == 0) $ 'Bluefin.Jump.jumpTo' done+-- 'Bluefin.Capability.JumpTo.withJumpTo' $ \\done -> forever $ do+-- n' <- 'Bluefin.Capability.Modify.get' n+-- 'Bluefin.Capability.Modify.modify' total (+ n')+-- when (n' == 0) $ 'Bluefin.Capability.JumpTo.jumpTo' done -- modify n (subtract 1) -- -- get total@@ -1459,12 +1593,12 @@ -- @ jumpTo :: (e <: es) =>- Jump e ->+ JumpTo e -> -- | ͘ Eff es a jumpTo tag = throw tag () -unwrap :: (e <: es) => Jump e -> Maybe a -> Eff es a+unwrap :: (e <: es) => JumpTo e -> Maybe a -> Eff es a unwrap j = \case Nothing -> jumpTo j Just a -> pure a@@ -1491,7 +1625,7 @@ IO a -> -- | ͘ Eff es a-effIO MkIOE = UnsafeMkEff+effIO MkIOE = UnsafeMkEff . const -- | Run an 'Eff' whose only unhandled effect is 'IO'. --@@ -1520,7 +1654,9 @@ (forall e. IOE e -> Eff e a) -> -- | ͘ IO a-runEff_ eff = unsafeUnEff (eff MkIOE)+runEff_ eff = do+ emptyEnv <- newIORef Vault.empty+ unsafeUnEff (eff MkIOE) emptyEnv unsafeProvideIO :: (forall e. IOE e -> Eff (e :& es) a) ->@@ -1528,40 +1664,10 @@ Eff es a unsafeProvideIO eff = useImplIn eff MkIOE -connect ::- (forall e1. Coroutine a b e1 -> Eff (e1 :& es) r1) ->- (forall e2. a -> Coroutine b a e2 -> Eff (e2 :& es) r2) ->- forall e1 e2.- (e1 <: es, e2 <: es) =>- Eff- es- ( Either- (r1, a -> Coroutine b a e2 -> Eff es r2)- (r2, b -> Coroutine a b e1 -> Eff es r1)- )-connect _ _ = error "connect unimplemented, sorry"--head' ::- forall a b r es.- (forall e. Coroutine a b e -> Eff (e :& es) r) ->- forall e.- (e <: es) =>- Eff- es- ( Either- r- (a, b -> Coroutine a b e -> Eff es r)- )-head' c = do- r <- connect c (\a _ -> pure a) @_ @es- pure $ case r of- Right r' -> Right r'- Left (l, _) -> Left l--newtype Writer w e = Writer (Stream w e)- deriving (Handle) via OneWayCoercibleHandle (Writer w)+newtype Tell w e = Tell (Yield w e)+ deriving (Handle) via OneWayCoercibleHandle (Tell w) -instance (e <: es) => OneWayCoercible (Writer w e) (Writer w es) where+instance (e <: es) => OneWayCoercible (Tell w e) (Tell w es) where oneWayCoercibleImpl = oneWayCoercible -- |@@ -1577,7 +1683,7 @@ (forall e. Writer w e -> Eff (e :& es) r) -> Eff es (r, w) runWriter f = runState mempty $ \st -> do- forEach (useImplUnder . f . Writer) $ \ww -> do+ forEach (useImplUnder . f . Tell) $ \ww -> do modify st (<> ww) -- |@@ -1610,24 +1716,35 @@ -- @ tell :: (e <: es) =>- Writer w e ->+ Tell w e -> -- | ͘ w -> Eff es ()-tell (Writer y) = yield y+tell (Tell y) = yield y -newtype Reader r e = MkReader (State r e)- deriving newtype (Handle)+type Ask :: Type -> Effects -> Type+newtype Ask r e = MkReader (Vault.Key r)+ deriving (Handle) via OneWayCoercibleHandle (Ask r) -instance (e <: es) => OneWayCoercible (Reader r e) (Reader r es) where+instance (e <: es) => OneWayCoercible (Ask r e) (Ask r es) where oneWayCoercibleImpl = oneWayCoercible +type role Ask representational nominal+ runReader :: -- | Initial value for @Reader@. r -> (forall e. Reader r e -> Eff (e :& es) a) -> Eff es a-runReader r f = evalState r (f . MkReader)+runReader r f = do+ bracket+ ( UnsafeMkEff $ \vault -> do+ k <- Vault.newKey+ modifyIORef' vault (\v -> Vault.insert k r v)+ pure k+ )+ (\k -> UnsafeMkEff $ \vault -> modifyIORef' vault (Vault.delete k))+ (\k -> makeOp (f (MkReader k))) -- | Read the value. Note that @ask@ has the property that these two -- operations are always equivalent:@@ -1647,38 +1764,53 @@ ask :: (e <: es) => -- | ͘- Reader r e ->+ Ask r e -> Eff es r-ask (MkReader st) = get st+ask (MkReader k) = UnsafeMkEff $ \vault -> do+ v <- readIORef vault+ case Vault.lookup k v of+ Nothing -> error msg+ Just ref -> pure ref+ where+ msg =+ unlines+ [ "ask called on out of scope reference",+ unwords+ [ "If you haven't subverted Bluefin's type system",+ "then this is a Bluefin bug.",+ "Please report it at",+ "https://github.com/tomjaguarpaw/bluefin/issues/new"+ ]+ ] -- | Read the value modified by a function asks :: (e <: es) =>- Reader r e ->+ Ask r e -> -- | Read the value modified by this function (r -> a) -> Eff es a-asks (MkReader st) f = fmap f (get st)+asks r f = fmap f (ask r) --- | Locally override the value in the @Reader@. It will be restored+-- | Locally override the value in the @Ask@. It will be restored -- when the @local@ block ends. local :: (e1 <: es) =>- Reader r e1 ->+ Ask r e1 -> -- | In the body, the reader value is modified by this function. (r -> r) -> -- | Body Eff es a -> Eff es a-local (MkReader st) f k = do- orig <- get st- bracket- (put st (f orig))- (\() -> put st orig)- (\() -> k)+local (MkReader key) f k = UnsafeMkEff $ \env@vault -> do+ orig <- readIORef vault+ Control.Exception.bracket+ (writeIORef vault (Vault.adjust f key orig))+ (\() -> writeIORef vault orig)+ (\() -> case k of UnsafeMkEff m -> m env) -newtype HandleReader h e = UnsafeMkHandleReader (State (h e) e)- deriving (Handle) via OneWayCoercibleHandle (HandleReader h)+newtype AskCapability h e = UnsafeMkHandleReader (Ask (h e) e)+ deriving (Handle) via OneWayCoercibleHandle (AskCapability h) -- In general this is really tremendously unsafe because we could take -- an `HandleReader h e`, map it to `HandleReader h es`, write an `h@@ -1695,8 +1827,11 @@ HandleReader h es mapHandleReader = case coerceH of Coercion -> coerce where+ oneWayCoerceH :: OneWayCoercion (h e) (h es)+ oneWayCoerceH = oneWayCoercion+ coerceH :: Coercion (h e) (h es)- coerceH = unsafeCoerce (Coercion :: Coercion (h e) (h e))+ coerceH = unsafeCoercionOfOneWayCoercion oneWayCoerceH localHandle :: (e <: es, Handle h) =>@@ -1705,20 +1840,16 @@ Eff es r -> -- | ͘ Eff es r-localHandle hh@(UnsafeMkHandleReader st) f k = do- let UnsafeMkHandleReader st' = mapHandle hh- orig <- get st- bracket- (put st' (f (mapHandle orig)))- (\() -> put st orig)- (\() -> k)+localHandle hh f k = do+ let UnsafeMkHandleReader st = mapHandle hh+ local st f k askHandle :: (e <: es, Handle h) => HandleReader h e -> -- | ͘ Eff es (h es)-askHandle hh = let UnsafeMkHandleReader st = mapHandle hh in get st+askHandle hh = let UnsafeMkHandleReader st = mapHandle hh in ask st asksHandle :: (e1 <: es, Handle h) =>@@ -1737,11 +1868,14 @@ -- | ͘ Eff es r runHandleReader h k = do- evalState (mapHandle h) $ \(st :: State (h es) e) -> do+ runReader (mapHandle h) $ \(st :: Ask (h es) e) -> do+ let oneWayCoerceH :: OneWayCoercion (h es) (h (e :& es))+ oneWayCoerceH = oneWayCoercion+ let coerceH :: Coercion (h es) (h (e :& es))- coerceH = unsafeCoerce (Coercion :: Coercion (h es) (h es))+ coerceH = unsafeCoercionOfOneWayCoercion oneWayCoerceH - let mapS :: State (h es) e' -> State (h (e :& es)) e'+ let mapS :: Ask (h es) e' -> Ask (h (e :& es)) e' mapS = case coerceH of Coercion -> coerce let h' :: HandleReader h (e :& es)@@ -1751,7 +1885,7 @@ useImplIn k h' -instance (e <: es) => OneWayCoercible (HandleReader h e) (HandleReader h es) where+instance (e <: es) => OneWayCoercible (AskCapability h e) (AskCapability h es) where oneWayCoercibleImpl = unsafeOneWayCoercible newtype ConstEffect r (e :: Effects) = MkConstEffect r@@ -1769,33 +1903,33 @@ -- Capbility synonyms -type Ask = Reader+type Reader = Ask -type AskCapability = HandleReader+type HandleReader = AskCapability -- | Capability to await values of type @a@-type Await a = Consume a+type Consume a = Await a -type JumpTo = Jump+type Jump = JumpTo -- | Capability to yield a value of type @a@ and then await a value of -- type @b@ in response.-type Request = Coroutine+type Coroutine = Request -type ReturnEarly = EarlyReturn+type EarlyReturn r = ReturnEarly r -- | Capability to modify a reference to an @s@-type Modify = State+type State = Modify -type Tell = Writer+type Writer = Tell -- | Capability to throw an exception of type @exn@-type Throw = Exception+type Exception = Throw -- | Capability to yield values of type @a@. It is implemented as a -- 'Bluefin.Capability.Request' capability that can yield values of -- type @a@ and then await values of type @()@.-type Yield a = Stream a+type Stream a = Yield a runAsk :: -- | Initial value for @Ask@.@@ -1828,7 +1962,7 @@ -- | 'awaitYield' is 'Bluefin.Capability.Request.connectRequests' -- specialized to @Await@ and @Yield@, which is the most common case. awaitYield ::- -- | Starts running first. Each 'await' from the @Consume@ ...+ -- | Starts running first. Each 'await' from the @Await@ ... (forall e. Await a e -> Eff (e :& es) r) -> -- | ... receives the value 'yield'ed from the @Yield@ (forall e. Yield a e -> Eff (e :& es) r) ->@@ -1877,7 +2011,7 @@ -- 42 -- @ ignoreYield ::- (forall e1. Stream a e1 -> Eff (e1 :& es) r) ->+ (forall e1. Yield a e1 -> Eff (e1 :& es) r) -> -- | ͘ Eff es r ignoreYield = ignoreStream@@ -1911,7 +2045,7 @@ -- "Returned early with 5" -- @ withReturnEarly ::- (forall e. EarlyReturn r e -> Eff (e :& es) r) ->+ (forall e. ReturnEarly r e -> Eff (e :& es) r) -> -- | ͘ Eff es r withReturnEarly = withEarlyReturn@@ -2002,14 +2136,16 @@ runAskCapability :: (e1 <: es, Handle h) => h e1 ->- (forall e. HandleReader h e -> Eff (e :& es) r) ->+ (forall e. AskCapability h e -> Eff (e :& es) r) -> -- | ͘ Eff es r runAskCapability = runHandleReader +-- | Do not use @askCapability@. It is unsafe and will be removed in+-- a future version. Use 'asksCapability' instead. askCapability :: (e <: es, Handle h) =>- HandleReader h e ->+ AskCapability h e -> -- | ͘ Eff es (h es) askCapability = askHandle@@ -2037,10 +2173,10 @@ -- n <- 'newState' source 5 -- total <- newState source 0 ----- 'Bluefin.JumpTo.withJumpTo' $ \\done -> forever $ do+-- 'Bluefin.Capability.JumpTo.withJumpTo' $ \\done -> forever $ do -- n' <- 'Bluefin.Capability.Modify.get' n -- 'Bluefin.Capability.Modify.modify' total (+ n')--- when (n' == 0) $ 'Bluefin.JumpTo.jumpTo' done+-- when (n' == 0) $ 'Bluefin.Capability.JumpTo.jumpTo' done -- modify n (subtract 1) -- -- get total
+ src/Bluefin/Internal/Capability/ThrowCatch.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Bluefin.Internal.Capability.ThrowCatch+ ( ThrowCatch,+ module Bluefin.Internal.Capability.ThrowCatch,+ )+where++import Bluefin.Internal+ ( ThrowCatch (MkThrowCatch),+ Eff,+ throwCatchTry,+ throwCatchThrow,+ unsafeProvideIO,+ useImpl,+ withEffToIO_,+ (:&),+ type (<:),+ )+import Bluefin.Internal.Exception.Scoped qualified as Scoped++try ::+ (forall e. ThrowCatch ex e -> Eff (e :& es) a) ->+ -- | ͘+ Eff es (Either ex a)+try = throwCatchTry++handle ::+ (ex -> Eff es a) ->+ (forall e. ThrowCatch ex e -> Eff (e :& es) a) ->+ -- | ͘+ Eff es a+handle h f =+ try f >>= \case+ Left ex -> h ex+ Right a -> pure a++catch ::+ (forall e. ThrowCatch ex e -> Eff (e :& es) a) ->+ (ex -> Eff es a) ->+ -- | ͘+ Eff es a+catch f h = handle h f++localCatch ::+ (e <: es) =>+ ThrowCatch ex e ->+ Eff es a ->+ (ex -> Eff es a) ->+ -- | ͘+ Eff es a+localCatch h action handler =+ localTry h action >>= \case+ Left ex -> handler ex+ Right a -> pure a++localHandle ::+ (e <: es) =>+ ThrowCatch ex e ->+ (ex -> Eff es a) ->+ Eff es a ->+ -- | ͘+ Eff es a+localHandle h handler action = localCatch h action handler++throw ::+ (e <: es) =>+ ThrowCatch ex e ->+ ex ->+ -- | ͘+ Eff es a+throw = throwCatchThrow++localTry ::+ (e <: es) =>+ ThrowCatch ex e ->+ Eff es a ->+ -- | ͘+ Eff es (Either ex a)+localTry h action = case h of+ MkThrowCatch ex ->+ unsafeProvideIO $ \io ->+ withEffToIO_ io $ \runInIO ->+ Scoped.localTry ex (runInIO (useImpl action))
src/Bluefin/Internal/CloneableHandle.hs view
@@ -34,12 +34,13 @@ ((forall r. (forall e. IOE e -> h e -> Eff e r) -> IO r) -> IO a) -> Eff es a withEffToIOCloneHandle io h k = do- withEffToIO_ io $ \runInIO -> do- k $ \body -> do- runInIO $ do- cloneHandleClass h $ \h' -> do- cloneHandleClass io $ \io' -> do- body (mapHandle io') (mapHandle h')+ withClonedEnv $ do+ withEffToIO_ io $ \runInIO -> do+ k $ \body -> do+ runInIO $ do+ cloneHandleClass h $ \h' -> do+ cloneHandleClass io $ \io' -> do+ body (mapHandle io') (mapHandle h') newtype HandleCloner h1 h2 es = MkHandleCloner@@ -76,35 +77,34 @@ hcIOE = MkHandleCloner $ \io k -> do useImplIn k (mapHandle io) --- | Cloning a @State@ copies its contents to a new @State@. Changes+-- | Cloning a @Modify@ copies its contents to a new @Modify@. Changes -- to one will not effect the other.-instance CloneableHandle (State s) where+instance CloneableHandle (Modify s) where cloneableHandleImpl = MkCloneableHandleD hcState -hcState :: HandleCloner (State s) (State s) e+hcState :: HandleCloner (Modify s) (Modify s) e hcState = MkHandleCloner $ \st k -> do s <- get st evalState s $ \st' -> useImplIn k (mapHandle st') -instance CloneableHandle (Exception a) where+instance CloneableHandle (Throw a) where cloneableHandleImpl = MkCloneableHandleD hcException -hcException :: HandleCloner (Exception ex) (Exception ex) e+hcException :: HandleCloner (Throw ex) (Throw ex) e hcException = MkHandleCloner $ \ex k -> do useImplIn k (mapHandle ex) -instance CloneableHandle (Reader r) where+instance CloneableHandle (Ask r) where cloneableHandleImpl = MkCloneableHandleD hcReader -hcReader :: HandleCloner (Reader r) (Reader r) e-hcReader = MkHandleCloner $ \(MkReader s) k -> do- cloneHandleClass s $ \s' -> do- useImplIn k (MkReader (mapHandle s'))+hcReader :: HandleCloner (Ask r) (Ask r) e+hcReader = MkHandleCloner $ \r k -> do+ useImplIn k (mapHandle r) --- | Cloning a @HandleReader@ copies its contents to a new--- @HandleReader@. Changes to one will not effect the other.-instance (CloneableHandle h) => CloneableHandle (HandleReader h) where+-- | Cloning an @AskCapability@ copies its contents to a new+-- @AskCapability@. Changes to one will not effect the other.+instance (CloneableHandle h) => CloneableHandle (AskCapability h) where cloneableHandleImpl = MkCloneableHandleD hcHandleReader cloneHandleClass ::@@ -115,26 +115,26 @@ cloneHandleClass = cloneHandle2 (case cloneableHandleImpl of MkCloneableHandleD c' -> c') -hcHandleReader :: (CloneableHandle h) => HandleCloner (HandleReader h) (HandleReader h) e+hcHandleReader :: (CloneableHandle h) => HandleCloner (AskCapability h) (AskCapability h) e hcHandleReader = MkHandleCloner $ \hr k -> do- h <- askHandle hr- cloneHandleClass h $ \h' -> do- runHandleReader h' $ \hr' -> do- useImplIn k (mapHandle hr')+ asksHandle hr $ \h -> do+ cloneHandleClass h $ \h' -> do+ runHandleReader h' $ \hr' -> do+ useImplIn k (mapHandle hr') instance- (TypeError (Text "Coroutine cannot be cloned. Perhaps you want an STM channel?")) =>- CloneableHandle (Coroutine a b)+ (TypeError (Text "Request cannot be cloned. Perhaps you want an STM channel?")) =>+ CloneableHandle (Request a b) where cloneableHandleImpl =- error "instance CloneableHandle (Coroutine a b) not implemented"+ error "instance CloneableHandle (Request a b) not implemented" instance- (TypeError (Text "Writer cannot be cloned. Perhaps you want an STM channel?")) =>- CloneableHandle (Writer w)+ (TypeError (Text "Tell cannot be cloned. Perhaps you want an STM channel?")) =>+ CloneableHandle (Tell w) where cloneableHandleImpl =- error "instance CloneableHandle (Writer a) not implemented"+ error "instance CloneableHandle (Tell a) not implemented" newtype (h1 :~> h2) es = MkArrow (forall e. h1 e -> h2 (e :& es)) @@ -254,7 +254,7 @@ -- example: -- -- @--- data MyHandle e = MkMyHandle ('Bluefin.Exception.Exception' String e) ('Bluefin.State.State' Int e)+-- data MyHandle e = MkMyHandle ('Bluefin.Capability.Throw.Throw' String e) ('Bluefin.Capability.Modify.Modify' Int e) -- deriving ('Bluefin.Compound.Generic', 'Generic1') -- deriving ('Bluefin.Compound.Handle') via t'Bluefin.Compound.OneWayCoercibleHandle' MyHandle -- deriving ('CloneableHandle') via 'GenericCloneableHandle' MyHandle
src/Bluefin/Internal/DslBuilder.hs view
@@ -3,11 +3,7 @@ module Bluefin.Internal.DslBuilder where import Bluefin.Internal-import Bluefin.Internal.DslBuilderEffects- ( DslBuilderEffects,- dslBuilderEffects,- runDslBuilderEffects,- )+import Bluefin.Internal.DslBuilderEff newtype Forall f r = MkForall {unForall :: forall es. f es r} @@ -27,13 +23,13 @@ unForall (f r) newtype DslBuilder h r- = MkDslBuilder {unMkDslBuilder :: Forall (DslBuilderEffects h) r}+ = MkDslBuilder {unMkDslBuilder :: Forall (DslBuilderEff h) r} runDslBuilder :: (Handle h) => h es -> DslBuilder h r -> Eff es r-runDslBuilder h f = runDslBuilderEffects h (unForall (unMkDslBuilder f))+runDslBuilder h f = runDslBuilderEff h (unForall (unMkDslBuilder f)) dslBuilder :: (forall e. h e -> Eff e r) -> DslBuilder h r-dslBuilder k = MkDslBuilder (mkForall (dslBuilderEffects (useImpl . k)))+dslBuilder k = MkDslBuilder (mkForall (dslBuilderEff (useImpl . k))) instance (Handle h) => Functor (DslBuilder h) where fmap f g = dslBuilder (\h -> fmap f (runDslBuilder h g))
src/Bluefin/Internal/DslBuilderEff.hs view
@@ -10,6 +10,8 @@ oneWayCoercible, oneWayCoercibleImpl, )+import GHC.Base (oneShot)+import GHC.IO (IO (IO)) newtype DslBuilderEff h es r = MkDslBuilderEff {unMkDslBuilderEff :: forall e. h e -> Eff (e :& es) r}@@ -27,12 +29,35 @@ -- | ͘ Eff es r runDslBuilderEff h f = makeOp (unMkDslBuilderEff f h)+{-# INLINE [0] runDslBuilderEff #-}+-- GHC's simplifier phase numbers count down toward 0. INLINE [0] keeps this+-- wrapper intact until phase 0, the final phase, so earlier simplifications+-- can work with the call before its body is exposed; it then strongly+-- encourages inlining to remove the wrapper. See+-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pragmas.html#phase-control +-- oneShot is essential for good performance. I don't fully understand+-- why.++runDslBuilderEffMappedArgs ::+ forall e1 e2 es h r.+ (Handle h, e1 <: es, e2 <: es) =>+ h e1 ->+ DslBuilderEff h e2 r ->+ -- | ͘+ Eff es r+runDslBuilderEffMappedArgs h f =+ runDslBuilderEff (mapHandle h) (useImplDslBuilderEff f)+{-# INLINE runDslBuilderEffMappedArgs #-}+ dslBuilderEff :: (forall e. h e -> Eff (e :& es) r) -> -- | ͘ DslBuilderEff h es r-dslBuilderEff = MkDslBuilderEff+dslBuilderEff f = MkDslBuilderEff $ \h -> case f h of+ UnsafeMkEff g -> UnsafeMkEff $ oneShot $ \env -> case g env of+ -- Expose IO's state transformer so it too can be marked one-shot+ IO io -> IO (oneShot io) instance (e <: es) =>@@ -43,15 +68,15 @@ instance (Handle h) => Functor (DslBuilderEff h es) where fmap f g = dslBuilderEff $ \h ->- fmap f (runDslBuilderEff (mapHandle h) (useImplDslBuilderEff g))+ fmap f (runDslBuilderEffMappedArgs h g) instance (Handle h) => Applicative (DslBuilderEff h es) where pure x = dslBuilderEff (pure (pure x)) f <*> x = dslBuilderEff $ \h ->- runDslBuilderEff (mapHandle h) (useImplDslBuilderEff f)- <*> runDslBuilderEff (mapHandle h) (useImplDslBuilderEff x)+ runDslBuilderEffMappedArgs h f+ <*> runDslBuilderEffMappedArgs h x instance (Handle h) => Monad (DslBuilderEff h es) where m >>= f = dslBuilderEff $ \h -> do- r <- runDslBuilderEff (mapHandle h) (useImplDslBuilderEff m)- runDslBuilderEff (mapHandle h) (useImplDslBuilderEff (f r))+ r <- runDslBuilderEffMappedArgs h m+ runDslBuilderEffMappedArgs h (f r)
− src/Bluefin/Internal/DslBuilderEffects.hs
@@ -1,48 +0,0 @@--- This will probably be superseded by DslBuilderEff because the--- latter has a better name-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE QuantifiedConstraints #-}--module Bluefin.Internal.DslBuilderEffects where--import Bluefin.Internal-import Bluefin.Internal.OneWayCoercible- ( OneWayCoercible,- oneWayCoerce,- oneWayCoercible,- oneWayCoercibleImpl,- )--newtype DslBuilderEffects h es r- = MkDslBuilderEffects {unMkDslBuilderEffects :: forall e. h e -> Eff (e :& es) r}--useImplDslBuilderEffects :: (e <: es) => DslBuilderEffects h e r -> DslBuilderEffects h es r-useImplDslBuilderEffects = oneWayCoerce--runDslBuilderEffects :: h es -> DslBuilderEffects h es r -> Eff es r-runDslBuilderEffects h f = makeOp (unMkDslBuilderEffects f h)--dslBuilderEffects :: (forall e. h e -> Eff (e :& es) r) -> DslBuilderEffects h es r-dslBuilderEffects = MkDslBuilderEffects--instance- (e <: es) =>- OneWayCoercible (DslBuilderEffects h e r) (DslBuilderEffects h es r)- where- oneWayCoercibleImpl = oneWayCoercible--instance (Handle h) => Functor (DslBuilderEffects h es) where- fmap f g =- dslBuilderEffects $ \h ->- fmap f (runDslBuilderEffects (mapHandle h) (useImplDslBuilderEffects g))--instance (Handle h) => Applicative (DslBuilderEffects h es) where- pure x = dslBuilderEffects (pure (pure x))- f <*> x = dslBuilderEffects $ \h ->- runDslBuilderEffects (mapHandle h) (useImplDslBuilderEffects f)- <*> runDslBuilderEffects (mapHandle h) (useImplDslBuilderEffects x)--instance (Handle h) => Monad (DslBuilderEffects h es) where- m >>= f = dslBuilderEffects $ \h -> do- r <- runDslBuilderEffects (mapHandle h) (useImplDslBuilderEffects m)- runDslBuilderEffects (mapHandle h) (useImplDslBuilderEffects (f r))
src/Bluefin/Internal/Examples.hs view
@@ -1,1086 +1,7 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE NoMonoLocalBinds #-}-{-# LANGUAGE NoMonomorphismRestriction #-}--module Bluefin.Internal.Examples where--import Bluefin.Internal hiding (b, w)-import Bluefin.Internal.OneWayCoercible-import Bluefin.Internal.Pipes- ( Producer,- runEffect,- stdinLn,- stdoutLn,- takeWhile',- (>->),- )-import Bluefin.Internal.Pipes qualified as P-import Control.Exception (IOException)-import Control.Exception qualified-import Control.Monad (forever, replicateM_, unless, when)-import Control.Monad.IO.Class (liftIO)-import Data.Foldable (for_)-import Data.Monoid (Any (Any, getAny))-import Data.Proxy (Proxy (Proxy))-import Text.Read (readMaybe)-import Prelude hiding- ( break,- drop,- head,- read,- readFile,- return,- writeFile,- )-import Prelude qualified--monadIOExample :: IO ()-monadIOExample = runEff $ \io -> withMonadIO io $ liftIO $ do- name <- readLn- putStrLn ("Hello " ++ name)--monadFailExample :: Either String ()-monadFailExample = runPureEff $ try $ \e ->- when ((2 :: Int) > 1) $- withMonadFail e (fail "2 was bigger than 1")--throwExample :: Either Int String-throwExample = runPureEff $ try $ \e -> do- _ <- throw e 42- pure "No exception thrown"--handleExample :: String-handleExample = runPureEff $ handle (pure . show) $ \e -> do- _ <- throw e (42 :: Int)- pure "No exception thrown"--exampleGet :: (Int, Int)-exampleGet = runPureEff $ runModify 10 $ \st -> do- n <- get st- pure (2 * n)--examplePut :: ((), Int)-examplePut = runPureEff $ runModify 10 $ \st -> do- put st 30--exampleModify :: ((), Int)-exampleModify = runPureEff $ runModify 10 $ \st -> do- modify st (* 2)--yieldExample :: ([Int], ())-yieldExample = runPureEff $ yieldToList $ \y -> do- yield y 1- yield y 2- yield y 100--withYieldToListExample :: Int-withYieldToListExample = runPureEff $ withYieldToList @Int $ \y -> do- yield y 1- yield y 2- yield y 100- pure length---- This shows we can use forEach at any level of nesting with--- insertManySecond-doubleNestedForEach ::- (forall e. Stream () e -> Eff (e :& es) ()) ->- Eff es ()-doubleNestedForEach f =- withModify () $ \_ -> do- withModify () $ \_ -> do- forEach (insertManySecond . f) (\_ -> pure ())- pure (\_ _ -> ())--forEachExample :: ([Int], ())-forEachExample = runPureEff $ yieldToList $ \y -> do- forEach (inFoldable [0 .. 4]) $ \i -> do- yield y i- yield y (i * 10)--ignoreStreamExample :: Int-ignoreStreamExample = runPureEff $ ignoreStream @Int $ \y -> do- for_ [0 .. 4] $ \i -> do- yield y i- yield y (i * 10)-- pure 42---- ([1,2,3,1,2,3],())-cycleToStreamExample :: ([Int], ())-cycleToStreamExample = runPureEff $ yieldToList $ \yOut -> do- consumeStream- (\c -> takeConsume 6 c yOut)- (\yIn -> cycleToStream [1 .. 3] yIn)---- ([1,2,3,4],())-takeConsumeExample :: ([Int], ())-takeConsumeExample = runPureEff $ yieldToList $ \yOut -> do- consumeStream- (\c -> takeConsume 4 c yOut)- (\yIn -> inFoldable [1 .. 10] yIn)--inFoldableExample :: ([Int], ())-inFoldableExample = runPureEff $ yieldToList $ inFoldable [1, 2, 100]--enumerateExample :: ([(Int, String)], ())-enumerateExample = runPureEff $ yieldToList $ enumerate (inFoldable ["A", "B", "C"])--returnEarlyExample :: String-returnEarlyExample = runPureEff $ withEarlyReturn $ \e -> do- for_ [1 :: Int .. 10] $ \i -> do- when (i >= 5) $- returnEarly e ("Returned early with " ++ show i)- pure "End of loop"--effIOExample :: IO ()-effIOExample = runEff $ \io -> do- effIO io (putStrLn "Hello world!")--example1_ :: (Int, Int)-example1_ =- let example1 :: Int -> Int- example1 n = runPureEff $ evalModify n $ \st -> do- n' <- get st- when (n' < 10) $- put st (n' + 10)- get st- in (example1 5, example1 12)--example2_ :: ((Int, Int), (Int, Int))-example2_ =- let example2 :: (Int, Int) -> (Int, Int)- example2 (m, n) = runPureEff $- evalModify m $ \sm -> do- evalModify n $ \sn -> do- do- n' <- get sn- m' <- get sm-- if n' < m'- then put sn (n' + 10)- else put sm (m' + 10)-- n' <- get sn- m' <- get sm-- pure (n', m')- in (example2 (5, 10), example2 (12, 5))--example3' :: Int -> Either String Int-example3' n = runPureEff $- try $ \ex -> do- evalModify 0 $ \total -> do- for_ [1 .. n] $ \i -> do- soFar <- get total- when (soFar > 20) $ do- throw ex ("Became too big: " ++ show soFar)- put total (soFar + i)-- get total---- Count non-empty lines from stdin, and print a friendly message,--- until we see "STOP".-example3_ :: IO ()-example3_ = runEff $ \io -> do- let getLineUntilStop y = withJump $ \stop -> forever $ do- line <- effIO io getLine- when (line == "STOP") $- jumpTo stop- yield y line-- nonEmptyLines =- mapMaybe- ( \case- "" -> Nothing- line -> Just line- )- getLineUntilStop-- enumeratedLines = enumerateFrom 1 nonEmptyLines-- formattedLines =- mapStream- (\(i, line) -> show i ++ ". Hello! You said " ++ line)- enumeratedLines-- forEach formattedLines $ \line -> effIO io (putStrLn line)--awaitList ::- (e <: es) =>- [a] ->- IOE e ->- (forall e1. Consume a e1 -> Eff (e1 :& es) ()) ->- Eff es ()-awaitList l io k = evalModify l $ \s -> do- withJump $ \done ->- bracket- (pure ())- (\() -> effIO io (putStrLn "Released"))- $ \() -> do- consumeEach (useImplUnder . k) $ do- (x, xs) <-- get s >>= \case- [] -> jumpTo done- x : xs -> pure (x, xs)- put s xs- pure x--takeRec ::- (e3 <: es) =>- Int ->- (forall e. Consume a e -> Eff (e :& es) ()) ->- Consume a e3 ->- Eff es ()-takeRec n k rec =- withJump $ \done -> evalModify n $ \s -> consumeEach (useImplUnder . k) $ do- s' <- get s- if s' <= 0- then jumpTo done- else do- modify s (subtract 1)- await rec--mapRec ::- (e <: es) =>- (a -> b) ->- (forall e1. Consume b e1 -> Eff (e1 :& es) ()) ->- Consume a e ->- Eff es ()-mapRec f = traverseRec (pure . f)--traverseRec ::- (e <: es) =>- (a -> Eff es b) ->- (forall e1. Consume b e1 -> Eff (e1 :& es) ()) ->- Consume a e ->- Eff es ()-traverseRec f k rec = forEach k $ \() -> do- r <- await rec- f r--awaitUsage ::- (e1 <: es, e2 <: es) =>- IOE e1 ->- (forall e. Consume () e -> Eff (e :& es) ()) ->- Consume Int e2 ->- Eff es ()-awaitUsage io x = do- mapRec (* 11) $- mapRec (subtract 1) $- takeRec 3 $- traverseRec (effIO io . print) $- useImplUnder . x--awaitExample :: IO ()-awaitExample = runEff $ \io -> do- awaitList [1 :: Int ..] io $ awaitUsage io $ \rec -> do- replicateM_ 5 (await rec)--consumeStreamExample :: IO (Either String String)-consumeStreamExample = runEff $ \io -> do- try $ \ex -> do- consumeStream- ( \r ->- bracket- (effIO io (putStrLn "Starting 2"))- (\_ -> effIO io (putStrLn "Leaving 2"))- $ \_ -> do- for_ [1 :: Int .. 100] $ \n -> do- b <- await r- effIO- io- ( putStrLn- ("Consumed body " ++ show b ++ " at time " ++ show n)- )- pure "Consumer finished first"- )- ( \y -> bracket- (effIO io (putStrLn "Starting 1"))- (\_ -> effIO io (putStrLn "Leaving 1"))- $ \_ -> do- for_ [1 :: Int .. 10] $ \n -> do- effIO io (putStrLn ("Sending " ++ show n))- yield y n- when (n > 5) $ do- effIO io (putStrLn "Aborting...")- throw ex "Aborted"-- pure "Yielder finished first"- )--consumeStreamExample2 :: IO ()-consumeStreamExample2 = runEff $ \io -> do- let counter yeven yodd = for_ [0 :: Int .. 10] $ \i -> do- if even i- then yield yeven i- else yield yodd i-- let foo yeven =- consumeStream- ( \r -> forever $ do- i <- await r- effIO io (putStrLn ("Odd: " ++ show i))- )- (counter yeven)-- let bar =- consumeStream- ( \r -> forever $ do- i <- await r- effIO io (putStrLn ("Even: " ++ show i))- )- foo-- bar--connectExample :: IO (Either String String)-connectExample = runEff $ \io -> do- try $ \ex -> do- connectCoroutines- ( \y -> bracket- (effIO io (putStrLn "Starting 1"))- (\_ -> effIO io (putStrLn "Leaving 1"))- $ \_ -> do- for_ [1 :: Int .. 10] $ \n -> do- effIO io (putStrLn ("Sending " ++ show n))- yield y n- when (n > 5) $ do- effIO io (putStrLn "Aborting...")- throw ex "Aborted"-- pure "Yielder finished first"- )- ( \binit r ->- bracket- (effIO io (putStrLn "Starting 2"))- (\_ -> effIO io (putStrLn "Leaving 2"))- $ \_ -> do- effIO io (putStrLn ("Consumed intial " ++ show binit))- for_ [1 :: Int .. 100] $ \n -> do- b <- await r- effIO- io- ( putStrLn- ("Consumed body " ++ show b ++ " at time " ++ show n)- )- pure "Consumer finished first"- )--zipCoroutinesExample :: IO ()-zipCoroutinesExample = runEff $ \io -> do- let m1 y = do- r <- yieldCoroutine y 1- evalModify r $ \rs -> do- for_ [1 .. 10 :: Int] $ \i -> do- r' <- get rs- r'' <- yieldCoroutine y (r' + i)- put rs r''-- let m2 y = do- r <- yieldCoroutine y 1- evalModify r $ \rs -> do- for_ [1 .. 5 :: Int] $ \i -> do- r' <- get rs- r'' <- yieldCoroutine y (r' - i)- put rs r''-- forEach (\c -> zipCoroutines c m1 m2) $ \i@(i1, i2) -> do- effIO io (print i)- pure (i1 + i2)---- Count the number of (strictly) positives and (strictly) negatives--- in a list, unless we see a zero, in which case we bail with an--- error message.-countPositivesNegatives :: [Int] -> String-countPositivesNegatives is = runPureEff $- evalModify (0 :: Int) $ \positives -> do- r <- try $ \ex ->- evalModify (0 :: Int) $ \negatives -> do- for_ is $ \i -> do- case compare i 0 of- GT -> modify positives (+ 1)- EQ -> throw ex ()- LT -> modify negatives (+ 1)-- p <- get positives- n <- get negatives-- pure $- "Positives: "- ++ show p- ++ ", negatives "- ++ show n-- case r of- Right r' -> pure r'- Left () -> do- p <- get positives- pure $- "We saw a zero, but before that there were "- ++ show p- ++ " positives"---- How to make compound effects--type MyHandle = Compound (Modify Int) (Throw String)--myInc :: (e <: es) => MyHandle e -> Eff es ()-myInc h = withCompound h (\s _ -> modify s (+ 1))--myBail :: (e <: es) => MyHandle e -> Eff es r-myBail h = withCompound h $ \s e -> do- i <- get s- throw e ("Current state was: " ++ show i)--runMyHandle ::- (forall e. MyHandle e -> Eff (e :& es) a) ->- Eff es (Either String (a, Int))-runMyHandle f =- try $ \e -> do- runModify 0 $ \s -> do- runCompound s e f--compoundExample :: Either String (a, Int)-compoundExample = runPureEff $ runMyHandle $ \h -> do- myInc h- myInc h- myBail h--countExample :: IO ()-countExample = runEff $ \io -> do- evalModify @Int 0 $ \sn -> do- withJump $ \break -> forever $ do- n <- get sn- when (n >= 10) (jumpTo break)- effIO io (print n)- modify sn (+ 1)--writerExample1 :: Bool-writerExample1 = getAny $ runPureEff $ execWriter $ \w -> do- for_ [] $ \_ -> tell w (Any True)--writerExample2 :: Bool-writerExample2 = getAny $ runPureEff $ execWriter $ \w -> do- for_ [1 :: Int .. 10] $ \_ -> tell w (Any True)--while :: Eff es Bool -> Eff es a -> Eff es ()-while condM body =- withJump $ \break_ -> do- forever $ do- cond <- insertFirst condM- unless cond (jumpTo break_)- insertFirst body--stateSourceExample :: Int-stateSourceExample = runPureEff $ withStateSource $ \source -> do- n <- newState source 5- total <- newState source 0-- withJump $ \done -> forever $ do- n' <- get n- modify total (+ n')- when (n' == 0) $ jumpTo done- modify n (subtract 1)-- get total--incrementReadLine ::- (e1 <: es, e2 <: es, e3 <: es) =>- Modify Int e1 ->- Throw String e2 ->- IOE e3 ->- Eff es ()-incrementReadLine state exception io = do- withJump $ \break -> forever $ do- line <- effIO io getLine- i <- case readMaybe line of- Nothing ->- throw exception ("Couldn't read: " ++ line)- Just i ->- pure i-- when (i == 0) $- jumpTo break-- modify state (+ i)--runIncrementReadLine :: IO (Either String Int)-runIncrementReadLine = runEff $ \io -> do- try $ \exception -> do- ((), r) <- runModify 0 $ \state -> do- incrementReadLine state exception io- pure r---- Counter 1--newtype Counter1 e = MkCounter1 (Modify Int e)--incCounter1 :: (e <: es) => Counter1 e -> Eff es ()-incCounter1 (MkCounter1 st) = modify st (+ 1)--runCounter1 ::- (forall e. Counter1 e -> Eff (e :& es) r) ->- Eff es Int-runCounter1 k =- evalModify 0 $ \st -> do- _ <- k (MkCounter1 st)- get st--exampleCounter1 :: Int-exampleCounter1 = runPureEff $ runCounter1 $ \c -> do- incCounter1 c- incCounter1 c- incCounter1 c---- > exampleCounter1--- 3---- Counter 2--data Counter2 e1 e2 = MkCounter2 (Modify Int e1) (Throw () e2)--incCounter2 :: (e1 <: es, e2 <: es) => Counter2 e1 e2 -> Eff es ()-incCounter2 (MkCounter2 st ex) = do- count <- get st- when (count >= 10) $- throw ex ()- put st (count + 1)--runCounter2 ::- (forall e1 e2. Counter2 e1 e2 -> Eff (e2 :& e1 :& es) r) ->- Eff es Int-runCounter2 k =- evalModify 0 $ \st -> do- _ <- try $ \ex -> do- k (MkCounter2 st ex)- get st--exampleCounter2 :: Int-exampleCounter2 = runPureEff $ runCounter2 $ \c ->- forever $- incCounter2 c---- > exampleCounter2--- 10---- Counter 3--data Counter3 e = MkCounter3 (Modify Int e) (Throw () e)--incCounter3 :: (e <: es) => Counter3 e -> Eff es ()-incCounter3 (MkCounter3 st ex) = do- count <- get st- when (count >= 10) $- throw ex ()- put st (count + 1)--runCounter3 ::- (forall e. Counter3 e -> Eff (e :& es) r) ->- Eff es Int-runCounter3 k =- evalModify 0 $ \st -> do- _ <- try $ \ex -> do- useImplIn k (MkCounter3 (mapHandle st) (mapHandle ex))- get st--exampleCounter3 :: Int-exampleCounter3 = runPureEff $ runCounter3 $ \c ->- forever $- incCounter3 c---- > exampleCounter3--- 10---- Counter 3B--newtype Counter3B e = MkCounter3B (IOE e)--incCounter3B :: (e <: es) => Counter3B e -> Eff es ()-incCounter3B (MkCounter3B io) =- effIO io (putStrLn "You tried to increment the counter")--runCounter3B ::- (e1 <: es) =>- IOE e1 ->- (forall e. Counter3B e -> Eff (e :& es) r) ->- Eff es r-runCounter3B io k = useImplIn k (MkCounter3B (mapHandle io))--exampleCounter3B :: IO ()-exampleCounter3B = runEff $ \io -> runCounter3B io $ \c -> do- incCounter3B c- incCounter3B c- incCounter3B c---- ghci> exampleCounter3B--- You tried to increment the counter--- You tried to increment the counter--- You tried to increment the counter---- Counter 4--data Counter4 e- = MkCounter4 (Modify Int e) (Throw () e) (Stream String e)--incCounter4 :: (e <: es) => Counter4 e -> Eff es ()-incCounter4 (MkCounter4 st ex y) = do- count <- get st-- when (even count) $- yield y "Count was even"-- when (count >= 10) $- throw ex ()-- put st (count + 1)--getCounter4 :: (e <: es) => Counter4 e -> String -> Eff es Int-getCounter4 (MkCounter4 st _ y) msg = do- yield y msg- get st--runCounter4 ::- (e1 <: es) =>- Stream String e1 ->- (forall e. Counter4 e -> Eff (e :& es) r) ->- Eff es Int-runCounter4 y k =- evalModify 0 $ \st -> do- _ <- try $ \ex -> do- useImplIn k (MkCounter4 (mapHandle st) (mapHandle ex) (mapHandle y))- get st--exampleCounter4 :: ([String], Int)-exampleCounter4 = runPureEff $ yieldToList $ \y -> do- runCounter4 y $ \c -> do- incCounter4 c- incCounter4 c- n <- getCounter4 c "I'm getting the counter"- when (n == 2) $- yield y "n was 2, as expected"---- > exampleCounter4--- (["Count was even","I'm getting the counter","n was 2, as expected"],2)---- Counter 5--data Counter5 e = MkCounter5- { incCounter5Impl :: Eff e (),- getCounter5Impl :: String -> Eff e Int- }- deriving (Generic)- deriving (Handle) via OneWayCoercibleHandle Counter5--instance (e <: es) => OneWayCoercible (Counter5 e) (Counter5 es) where- oneWayCoercibleImpl = gOneWayCoercible--incCounter5 :: (e <: es) => Counter5 e -> Eff es ()-incCounter5 e = incCounter5Impl (mapHandle e)--getCounter5 :: (e <: es) => Counter5 e -> String -> Eff es Int-getCounter5 e msg = getCounter5Impl (mapHandle e) msg--runCounter5 ::- (e1 <: es) =>- Stream String e1 ->- (forall e. Counter5 e -> Eff (e :& es) r) ->- Eff es Int-runCounter5 y k =- evalModify 0 $ \st -> do- _ <- try $ \ex -> do- useImplIn- k- ( MkCounter5- { incCounter5Impl = do- count <- get st-- when (even count) $- yield y "Count was even"-- when (count >= 10) $- throw ex ()-- put st (count + 1),- getCounter5Impl = \msg -> do- yield y msg- get st- }- )- get st--exampleCounter5 :: ([String], Int)-exampleCounter5 = runPureEff $ yieldToList $ \y -> do- runCounter5 y $ \c -> do- incCounter5 c- incCounter5 c- n <- getCounter5 c "I'm getting the counter"- when (n == 2) $- yield y "n was 2, as expected"---- > exampleCounter5--- (["Count was even","I'm getting the counter","n was 2, as expected"],2)---- Counter 6--data Counter6 e = MkCounter6- { incCounter6Impl :: Eff e (),- counter6Modify :: Modify Int e,- counter6Stream :: Stream String e- }- deriving (Generic)- deriving (Handle) via OneWayCoercibleHandle Counter6--instance (e <: es) => OneWayCoercible (Counter6 e) (Counter6 es) where- oneWayCoercibleImpl = gOneWayCoercible--incCounter6 :: (e <: es) => Counter6 e -> Eff es ()-incCounter6 e = incCounter6Impl (mapHandle e)--getCounter6 :: (e <: es) => Counter6 e -> String -> Eff es Int-getCounter6 (MkCounter6 _ st y) msg = do- yield y msg- get st--runCounter6 ::- (e1 <: es) =>- Stream String e1 ->- (forall e. Counter6 e -> Eff (e :& es) r) ->- Eff es Int-runCounter6 y k =- evalModify 0 $ \st -> do- _ <- try $ \ex -> do- useImplIn- k- ( MkCounter6- { incCounter6Impl = do- count <- get st-- when (even count) $- yield y "Count was even"-- when (count >= 10) $- throw ex ()-- put st (count + 1),- counter6Modify = mapHandle st,- counter6Stream = mapHandle y- }- )- get st--exampleCounter6 :: ([String], Int)-exampleCounter6 = runPureEff $ yieldToList $ \y -> do- runCounter6 y $ \c -> do- incCounter6 c- incCounter6 c- n <- getCounter6 c "I'm getting the counter"- when (n == 2) $- yield y "n was 2, as expected"---- > exampleCounter6--- (["Count was even","I'm getting the counter","n was 2, as expected"],2)---- Counter 7--data Counter7 e = MkCounter7- { incCounter7Impl :: forall e'. Throw () e' -> Eff (e' :& e) (),- counter7Modify :: Modify Int e,- counter7Stream :: Stream String e- }- deriving (Handle) via OneWayCoercibleHandle Counter7---- | The "forall" in the type of @incCounter7@ means that we can't--- derive the @OneWayCoercible@ instance with 'gOneWayCoercible' so--- instead we use @oneWayCoercibleTrustMe@.-instance (e <: es) => OneWayCoercible (Counter7 e) (Counter7 es) where- oneWayCoercibleImpl = oneWayCoercibleTrustMe $ \c ->- MkCounter7- { incCounter7Impl = \ex -> useImplUnder (incCounter7Impl c ex),- counter7Modify = mapHandle (counter7Modify c),- counter7Stream = mapHandle (counter7Stream c)- }--incCounter7 ::- (e <: es, e1 <: es) => Counter7 e -> Throw () e1 -> Eff es ()-incCounter7 e ex = makeOp (incCounter7Impl (mapHandle e) (mapHandle ex))--getCounter7 :: (e <: es) => Counter7 e -> String -> Eff es Int-getCounter7 (MkCounter7 _ st y) msg = do- yield y msg- get st--runCounter7 ::- (e1 <: es) =>- Stream String e1 ->- (forall e. Counter7 e -> Eff (e :& es) r) ->- Eff es Int-runCounter7 y k =- evalModify 0 $ \st -> do- _ <-- useImplIn- k- ( MkCounter7- { incCounter7Impl = \ex -> do- count <- get st-- when (even count) $- yield y "Count was even"-- when (count >= 10) $- throw ex ()-- put st (count + 1),- counter7Modify = mapHandle st,- counter7Stream = mapHandle y- }- )- get st--exampleCounter7A :: ([String], Int)-exampleCounter7A = runPureEff $ yieldToList $ \y -> do- handle (\() -> pure (-42)) $ \ex ->- runCounter7 y $ \c -> do- incCounter7 c ex- incCounter7 c ex- n <- getCounter7 c "I'm getting the counter"- when (n == 2) $- yield y "n was 2, as expected"---- > exampleCounter7A--- (["Count was even","I'm getting the counter","n was 2, as expected"],2)--exampleCounter7B :: ([String], Int)-exampleCounter7B = runPureEff $ yieldToList $ \y -> do- handle (\() -> pure (-42)) $ \ex ->- runCounter7 y $ \c -> do- forever (incCounter7 c ex)---- > exampleCounter7B--- (["Count was even","Count was even","Count was even","Count was even","Count was even","Count was even"],-42)---- FileSystem--data FileSystem es = MkFileSystem- { readFileImpl :: FilePath -> Eff es String,- writeFileImpl :: FilePath -> String -> Eff es ()- }- deriving (Generic)- deriving (Handle) via OneWayCoercibleHandle FileSystem--instance (e <: es) => OneWayCoercible (FileSystem e) (FileSystem es) where- oneWayCoercibleImpl = gOneWayCoercible--readFile :: (e <: es) => FileSystem e -> FilePath -> Eff es String-readFile fs filepath = readFileImpl (mapHandle fs) filepath--writeFile :: (e <: es) => FileSystem e -> FilePath -> String -> Eff es ()-writeFile fs filepath contents =- writeFileImpl (mapHandle fs) filepath contents--runFileSystemPure ::- (e1 <: es) =>- Throw String e1 ->- [(FilePath, String)] ->- (forall e2. FileSystem e2 -> Eff (e2 :& es) r) ->- Eff es r-runFileSystemPure ex fs0 k =- evalModify fs0 $ \fs ->- useImplIn- k- MkFileSystem- { readFileImpl = \path -> do- fs' <- get fs- case lookup path fs' of- Nothing ->- throw ex ("File not found: " <> path)- Just s -> pure s,- writeFileImpl = \path contents ->- modify fs ((path, contents) :)- }--runFileSystemIO ::- forall e1 e2 es r.- (e1 <: es, e2 <: es) =>- Throw String e1 ->- IOE e2 ->- (forall e. FileSystem e -> Eff (e :& es) r) ->- Eff es r-runFileSystemIO ex io k =- useImplIn- k- MkFileSystem- { readFileImpl =- adapt . Prelude.readFile,- writeFileImpl =- \path -> adapt . Prelude.writeFile path- }- where- adapt :: (e1 <: ess, e2 <: ess) => IO a -> Eff ess a- adapt m =- effIO io (Control.Exception.try @IOException m) >>= \case- Left e -> throw ex (show e)- Right r -> pure r--action :: (e <: es) => FileSystem e -> Eff es String-action fs = do- file <- readFile fs "/dev/null"- when (length file == 0) $ do- writeFile fs "/tmp/bluefin" "Hello!\n"- readFile fs "/tmp/doesn't exist"--exampleRunFileSystemPure :: Either String String-exampleRunFileSystemPure = runPureEff $ try $ \ex ->- runFileSystemPure ex [("/dev/null", "")] action---- > exampleRunFileSystemPure--- Left "File not found: /tmp/doesn't exist"--exampleRunFileSystemIO :: IO (Either String String)-exampleRunFileSystemIO = runEff $ \io -> try $ \ex ->- runFileSystemIO ex io action---- > exampleRunFileSystemIO--- Left "/tmp/doesn't exist: openFile: does not exist (No such file or directory)"--- \$ cat /tmp/bluefin--- Hello!---- instance Handle example--data Application e = MkApplication- { queryDatabase :: String -> Int -> Eff e [String],- applicationModify :: Modify (Int, Bool) e,- logger :: Stream String e- }- deriving (Generic)- deriving (Handle) via OneWayCoercibleHandle Application--instance (e <: es) => OneWayCoercible (Application e) (Application es) where- oneWayCoercibleImpl = gOneWayCoercible---- This example shows a case where we can use @bracket@ polymorphically--- in order to perform correct cleanup if @es@ is instantiated to a--- set of effects that includes exceptions.-polymorphicBracket ::- (st <: es) =>- Modify (Integer, Bool) st ->- Eff es () ->- Eff es ()-polymorphicBracket st act =- bracket- (pure ())- -- Always set the boolean indicating that we have terminated- (\_ -> modify st (\(c, _b) -> (c, True)))- -- Perform the given effectful action, then increment the counter- (\_ -> do act; modify st (\(c, b) -> ((c + 1), b)))---- Results in (1, True)-polymorphicBracketExample1 :: (Integer, Bool)-polymorphicBracketExample1 =- runPureEff $ do- (_res, st) <- runModify (0, False) $ \st -> polymorphicBracket st (pure ())- pure st---- Results in (0, True)-polymorphicBracketExample2 :: (Integer, Bool)-polymorphicBracketExample2 =- runPureEff $ do- (_res, st) <- runModify (0, False) $ \st -> try @Int $ \e -> polymorphicBracket st (throw e 42)- pure st--pipesExample1 :: IO ()-pipesExample1 = runEff $ \io -> runEffect (count >-> P.print io)- where- count :: (e <: es) => Producer Int e -> Eff es ()- count p = for_ [1 .. 5] $ \i -> P.yield p i--pipesExample2 :: IO String-pipesExample2 = runEff $ \io -> runEffect $ do- stdinLn io >-> takeWhile' (/= "quit") >-> stdoutLn io---- Acquiring resource--- 1--- 2--- 3--- 4--- 5--- Releasing resource--- Finishing-promptCoroutine :: IO ()-promptCoroutine = runEff $ \io -> do- -- consumeStream connects a consumer to a producer- consumeStream- -- Like a pipes Consumer. Prints the first five elements it- -- awaits.- ( \r -> for_ [1 :: Int .. 5] $ \_ -> do- v <- await r- effIO io (print v)- )- -- Like a pipes Producer. Yields successive integers indefinitely.- -- Unlike in pipes, we can simply use Bluefin's standard bracket- -- for prompt release of a resource- ( \y ->- bracket- (effIO io (putStrLn "Acquiring resource"))- (\_ -> effIO io (putStrLn "Releasing resource"))- (\_ -> for_ [1 :: Int ..] $ \i -> yield y i)- )- effIO io (putStrLn "Finishing")--rethrowIOExample :: IO ()-rethrowIOExample = runEff $ \io -> do- r <- try $ \ex -> do- rethrowIO @Control.Exception.IOException io ex $ do- effIO io (Prelude.readFile "/tmp/doesnt-exist")-- effIO io $ putStrLn $ case r of- Left e -> "Caught IOException:\n" ++ show e- Right contents -> contents---- | The "forall" in the type of @localRImpl@ means that we can't--- derive the @OneWayCoercible@ instance with 'gOneWayCoercible' so--- instead we use @oneWayCoercibleTrustMe@.-data DynamicReader r e = DynamicReader- { askLRImpl :: Eff e r,- localLRImpl :: forall e' a. (r -> r) -> Eff e' a -> Eff (e' :& e) a- }- deriving (Handle) via OneWayCoercibleHandle (DynamicReader r)--instance- (e <: es) =>- OneWayCoercible (DynamicReader r e) (DynamicReader r es)- where- oneWayCoercibleImpl = oneWayCoercibleTrustMe $ \h ->- DynamicReader- { askLRImpl = useImpl (askLRImpl h),- localLRImpl = \f k -> useImplUnder (localLRImpl h f k)- }--askLR ::- (e <: es) =>- DynamicReader r e ->- Eff es r-askLR c = askLRImpl (mapHandle c)--localLR ::- (e <: es) =>- DynamicReader r e ->- (r -> r) ->- Eff es a ->- Eff es a-localLR c f m = makeOp (localLRImpl (mapHandle c) f m)--runDynamicReader ::- r ->- (forall e. DynamicReader r e -> Eff (e :& es) a) ->- Eff es a-runDynamicReader r k =- runReader r $ \h -> do- useImplIn- k- DynamicReader- { askLRImpl = ask h,- localLRImpl = \f k' -> local h f (useImpl k')- }+module Bluefin.Internal.Examples where++import Bluefin.Internal+import Data.Proxy (Proxy (Proxy)) -- Fails to compile unless '(e <: es) => e <: (x :& es)' is incoherent -- (otherwise I guess it "commits to it too soon")
src/Bluefin/Internal/Exception.hs view
@@ -7,7 +7,7 @@ import Bluefin.Internal ( Eff,- Exception (..),+ Throw (..), Handle, OneWayCoercibleHandle (..), effIO,@@ -156,7 +156,7 @@ forall ex r a es. (r -> ex -> Eff es a) -> -- | ͘- MakeExceptions r a (Exception ex) es+ MakeExceptions r a (Throw ex) es catchWithResource f = MkMakeExceptions $ unsafeProvideIO $ \io -> do scopedEx <- effIO io (SE.newException @ex) let hk = MkHandledKey scopedEx (flip f)
src/Bluefin/Internal/Exception/Scoped.hs view
@@ -2,6 +2,7 @@ ( Exception, InFlight, try,+ localTry, throw, newException, checkException,@@ -17,9 +18,13 @@ try :: (Exception e -> IO a) -> IO (Either e a) try k = do ex <- newException+ localTry ex (k ex)++localTry :: Exception e -> IO a -> IO (Either e a)+localTry ex action = tryJust (checkException ex)- (k ex)+ action throw :: Exception e -> e -> IO a throw ex e = throwIO (MkInFlight ex e)
src/Bluefin/Internal/GadtEffect.hs view
@@ -6,7 +6,7 @@ ( Eff, Effects, Handle,- HandleReader,+ AskCapability, OneWayCoercibleHandle (..), localHandle, mapHandle,@@ -69,7 +69,7 @@ -- forall es e1 e2 r. -- (e1 \<: es, e2 \<: es) => -- t'Bluefin.IO.IOE' e1 ->--- t'Bluefin.Exception.Exception' t'Control.Exception.IOException' e2 ->+-- t'Bluefin.Capability.Throw.Throw' t'Control.Exception.IOException' e2 -> -- (forall e. 'Send' FileSystem e -> Eff (e :& es) r) -> -- Eff es r -- runFileSystem io ex = 'interpret' $ \\case@@ -129,7 +129,7 @@ -- augmentOp2Interpose :: -- (e1 \<: es, e2 \<: es) => -- IOE e2 ->--- t'Bluefin.HandleReader.HandleReader' (Send E) e1 ->+-- t'Bluefin.Capability.AskCapability.AskCapability' (Send E) e1 -> -- Eff es r -> -- Eff es r -- augmentOp2Interpose io = 'interpose' $ \\fc -> \\case@@ -149,7 +149,7 @@ -- augmentOp2Interpose :: -- (e1 \<: es, e2 \<: es) => -- IOE e2 ->--- t'Bluefin.HandleReader.HandleReader' (Send E) e1 ->+-- t'Bluefin.Capability.AskCapability.AskCapability' (Send E) e1 -> -- Eff es r -> -- Eff es r -- augmentOp2Interpose io = 'interpose' $ \\fc -> \\case@@ -162,7 +162,7 @@ -- the original effect handler, which is passed as the argument (Send f es -> EffectHandler f es) -> -- | Original effect handler- HandleReader (Send f) e1 ->+ AskCapability (Send f) e1 -> -- | Within this block, @send@ has the implementation given above. Eff es r -> Eff es r
src/Bluefin/Internal/OneWayCoercible.hs view
@@ -1,3 +1,13 @@+-- | 'OneWayCoercible' morally belongs to GHC as erased,+-- compiler-checked evidence of representational "castability"+-- (i.e. conversion in one direction only), just like 'Coercible` is+-- evidence of representational equality (i.e. "castability" in both+-- directions). But such a feature is missing in GHC and Bluefin+-- simulates it with an ordinary class. To obtain zero-cost+-- conversions it must trust the evidence without evaluating its+-- dictionary, introducing potential unsafety when 'OneWayCoercible'+-- instances are not valid.+ {-# OPTIONS_HADDOCK not-home #-} module Bluefin.Internal.OneWayCoercible@@ -46,6 +56,9 @@ oneWayCoerce :: forall a b. (OneWayCoercible a b) => a -> b oneWayCoerce = oneWayCoerceWith (oneWayCoercion @a @b) +unsafeOneWayCoerce :: forall a b. (OneWayCoercible a b) => a -> b+unsafeOneWayCoerce = unsafeCoerce+ oneWayCoerceWith :: OneWayCoercion a b -> a -> b oneWayCoerceWith (MkOneWayCoercion Coercion) = coerce @@ -95,6 +108,18 @@ trans c1 c2 = case unsafeCoercionOfOneWayCoercion c1 of Coercion -> case unsafeCoercionOfOneWayCoercion c2 of Coercion -> MkOneWayCoercion Coercion++trans3D ::+ forall t1 t2 t3 t4.+ OneWayCoercibleD t1 t2 ->+ OneWayCoercibleD t2 t3 ->+ OneWayCoercibleD t3 t4 ->+ OneWayCoercibleD t1 t4+trans3D+ (MkOneWayCoercibleD t1t2)+ (MkOneWayCoercibleD t2t3)+ (MkOneWayCoercibleD t3t4) =+ MkOneWayCoercibleD ((t1t2 `trans` t2t3) `trans` t3t4) class GOneWayCoercible a b
− src/Bluefin/Internal/Pipes.hs
@@ -1,285 +0,0 @@-module Bluefin.Internal.Pipes where--import Bluefin.Internal- ( Coroutine,- Eff,- IOE,- effIO,- evalState,- forEach,- get,- mapHandle,- put,- receiveStream,- returnEarly,- useImpl,- useImplIn,- withEarlyReturn,- yieldCoroutine,- (:&),- type (<:),- )-import Bluefin.Internal qualified-import Control.Monad (forever)-import Data.Foldable (for_)-import Data.Void (Void, absurd)-import Prelude hiding (break, print, takeWhile)-import Prelude qualified--data Proxy a' a b' b e = MkProxy (Coroutine a' a e) (Coroutine b b' e)--type Pipe a = Proxy () a ()--type Producer = Proxy Void () ()--type Consumer a = Pipe a Void--type Effect = Producer Void--infixl 7 >->--(>->) ::- (e1 <: es) =>- (forall e. Proxy a' a () b e -> Eff (e :& es) r) ->- (forall e. Proxy () b c' c e -> Eff (e :& es) r) ->- Proxy a' a c' c e1 ->- -- | ͘- Eff es r-(>->) k1 k2 (MkProxy c1 c2) =- receiveStream- (\c -> useImplIn k2 (MkProxy (mapHandle c) (mapHandle c2)))- (\s -> useImplIn k1 (MkProxy (mapHandle c1) (mapHandle s)))--infixr 7 <-<--(<-<) ::- (e1 <: es) =>- (forall e. Proxy () b c' c e -> Eff (e :& es) r) ->- (forall e. Proxy a' a () b e -> Eff (e :& es) r) ->- Proxy a' a c' c e1 ->- -- | ͘- Eff es r-k1 <-< k2 = k2 >-> k1--for ::- (e1 <: es) =>- (forall e. Proxy x' x b' b e -> Eff (e :& es) a') ->- (b -> forall e. Proxy x' x c' c e -> Eff (e :& es) b') ->- Proxy x' x c' c e1 ->- -- | ͘- Eff es a'-for k1 k2 (MkProxy c1 c2) =- forEach (\bk -> useImplIn k1 (MkProxy (mapHandle c1) (mapHandle bk))) $ \b_ ->- useImplIn (k2 b_) (MkProxy (mapHandle c1) (mapHandle c2))--infixr 4 ~>--(~>) ::- (e1 <: es) =>- (a -> forall e. Proxy x' x b' b e -> Eff (e :& es) a') ->- (b -> forall e. Proxy x' x c' c e -> Eff (e :& es) b') ->- a ->- Proxy x' x c' c e1 ->- -- | ͘- Eff es a'-(k1 ~> k2) a = for (k1 a) k2--infixl 4 <~--(<~) ::- (e1 <: es) =>- (b -> forall e. Proxy x' x c' c e -> Eff (e :& es) b') ->- (a -> forall e. Proxy x' x b' b e -> Eff (e :& es) a') ->- a ->- Proxy x' x c' c e1 ->- -- | ͘- Eff es a'-k2 <~ k1 = k1 ~> k2--reverseProxy :: Proxy a' a b' b e -> Proxy b b' a a' e-reverseProxy (MkProxy c1 c2) = MkProxy c2 c1--infixl 5 >~--(>~) ::- (e1 <: es) =>- (forall e. Proxy a' a y' y e -> Eff (e :& es) b) ->- (forall e. Proxy () b y' y e -> Eff (e :& es) c) ->- Proxy a' a y' y e1 ->- -- | ͘- Eff es c-(>~) k1 k2 p =- for- ( \p1 ->- k2 (reverseProxy p1)- )- (\() p1 -> k1 (reverseProxy p1))- (reverseProxy p)--infixr 5 ~<--(~<) ::- (e1 <: es) =>- (forall e. Proxy () b y' y e -> Eff (e :& es) c) ->- (forall e. Proxy a' a y' y e -> Eff (e :& es) b) ->- Proxy a' a y' y e1 ->- -- | ͘- Eff es c-(~<) k1 k2 = (>~) k2 k1--cat :: Pipe a a e -> Eff (e :& es) r-cat (MkProxy c1 c2) = forever $ do- a <- yieldCoroutine c1 ()- yieldCoroutine c2 a--runEffect ::- (forall e. Effect e -> Eff (e :& es) r) ->- -- | ͘- Eff es r-runEffect k =- forEach- ( \c1 ->- forEach- ( \c2 ->- useImplIn- k- (MkProxy (mapHandle c1) (mapHandle c2))- )- absurd- )- absurd--yield ::- (e <: es) =>- Proxy x1 x () a e ->- a ->- -- | ͘- Eff es ()-yield (MkProxy _ c) = Bluefin.Internal.yield c--await :: (e <: es) => Proxy () a y' y e -> Eff es a-await (MkProxy c _) = yieldCoroutine c ()---- | @pipe@'s 'next' doesn't exist in Bluefin-next :: ()-next = ()--each ::- (Foldable f) =>- f a ->- Proxy x' x () a e ->- -- | ͘- Eff (e :& es) ()-each f p = for_ f (yield p)--repeatM ::- (e <: es) =>- Eff es a ->- Proxy x' x () a e ->- -- | ͘- Eff es r-repeatM e p = forever $ do- a <- e- yield p a--replicateM ::- (e <: es) =>- Int ->- Eff es a ->- Proxy x' x () a e ->- -- | ͘- Eff es ()-replicateM n e p = for_ [0 .. n] $ \_ -> do- a <- e- yield p a--print ::- (e2 <: es, e1 <: es, Show a) =>- IOE e1 ->- Consumer a e2 ->- -- | ͘- Eff es r-print io p = forever $ do- a <- await p- effIO io (Prelude.print a)--unfoldr ::- (e <: es) =>- (s -> Eff es (Either r (a, s))) ->- s ->- Proxy x1 x () a e ->- -- | ͘- Eff es r-unfoldr next_ sInit p =- withEarlyReturn $ \break -> evalState sInit $ \ss -> forever $ do- s <- get ss- useImpl (next_ s) >>= \case- Left r -> returnEarly break r- Right (a, s') -> do- put ss s'- yield p a--mapM_ ::- (e <: es) =>- (a -> Eff es ()) ->- Proxy () a b b' e ->- -- | ͘- Eff es r-mapM_ f = for cat (\a _ -> useImpl (f a))--drain ::- (e <: es) =>- Proxy () b c' c e ->- -- | ͘- Eff es r-drain = for cat (\_ _ -> pure ())--map ::- (e <: es) =>- (a -> b) ->- Pipe a b e ->- -- | ͘- Eff es r-map f = for cat (\a p1 -> yield p1 (f a))--mapM ::- (e <: es) =>- (a -> Eff es b) ->- Pipe a b e ->- -- | ͘- Eff es r-mapM f = for cat $ \a p -> do- b_ <- useImpl (f a)- yield p b_--takeWhile' ::- (e <: es) =>- (r -> Bool) ->- Pipe r r e ->- -- | ͘- Eff es r-takeWhile' predicate p = withEarlyReturn $ \early -> forever $ do- a <- await p- if predicate a- then yield p a- else returnEarly early a--stdinLn ::- (e1 <: es, e2 <: es) =>- IOE e1 ->- Producer String e2 ->- -- | ͘- Eff es r-stdinLn io c = forever $ do- line <- effIO io getLine- yield c line--stdoutLn ::- (e1 <: es, e2 <: es) =>- IOE e1 ->- Consumer String e2 ->- -- | ͘- Eff es r-stdoutLn io c = forever $ do- line <- await c- effIO io (putStrLn line)
src/Bluefin/Internal/Prim.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UnboxedTuples #-} module Bluefin.Internal.Prim where@@ -21,19 +22,23 @@ unsafeOneWayCoercible, ) import Control.Monad.Primitive qualified as P+import Data.Kind (Type) import GHC.Exts (State#) import Unsafe.Coerce (unsafeCoerce) -data Prim (e :: Effects) = UnsafeMkPrim- deriving (Handle) via OneWayCoercibleHandle Prim+type Prim :: Effects -> Effects -> Type+data Prim e1 e2 = UnsafeMkPrim+ deriving (Handle) via OneWayCoercibleHandle (Prim e1) +type role Prim nominal nominal+ data PrimStateEff (es :: Effects) -instance (e <: es) => OneWayCoercible (Prim e) (Prim es) where+instance (e2 <: es) => OneWayCoercible (Prim e1 e2) (Prim e1 es) where oneWayCoercibleImpl = unsafeOneWayCoercible runPrim ::- (forall e. Prim e -> Eff (e :& es) r) ->+ (forall e. Prim e e -> Eff (e :& es) r) -> -- | ͘ Eff es r runPrim k = makeOp (k UnsafeMkPrim)@@ -44,9 +49,9 @@ unsafeCoerceStateM = unsafeCoerce primitive ::- forall e1 es a.- (e1 <: es) =>- Prim e1 ->+ forall e1 e2 es a.+ (e2 <: es) =>+ Prim e1 e2 -> (State# (PrimStateEff e1) -> (# State# (PrimStateEff e1), a #)) -> -- | ͘ Eff es a
+ src/Bluefin/Internal/Vault.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE RoleAnnotations #-}++module Bluefin.Internal.Vault+ ( module Bluefin.Internal.Vault,+ Vault,+ Vault.empty,+ )+where++import Data.Kind (Type)+import Data.Vault.Strict (Vault)+import Data.Vault.Strict qualified as Vault+import GHC.Exts (Any)+import Unsafe.Coerce (unsafeCoerce)++-- Vault.Key doesn't have representational role for its "value"+-- argument. I think it should. We hack it.+--+-- https://github.com/HeinrichApfelmus/vault/issues/56+type Key :: Type -> Type+newtype Key a = MkKey (Vault.Key Any)++type role Key representational++fromMine :: Key a -> Vault.Key a+fromMine (MkKey k) = unsafeCoerce k++toMine :: Vault.Key a -> Key a+toMine k = MkKey (unsafeCoerce k)++lookup :: Key a -> Vault -> Maybe a+lookup = Vault.lookup . fromMine++adjust :: (a -> a) -> Key a -> Vault -> Vault+adjust f = Vault.adjust f . fromMine++newKey :: IO (Key a)+newKey = fmap toMine Vault.newKey++insert :: Key a -> a -> Vault -> Vault+insert = Vault.insert . fromMine++delete :: Key a -> Vault -> Vault+delete = Vault.delete . fromMine
test/Main.hs view
@@ -4,10 +4,22 @@ module Main (main) where import Bluefin.Internal+import Bluefin.Internal.Vault qualified as Vault+import Control.Exception (AsyncException (ThreadKilled)) import Control.Monad (forever, when) import Data.Foldable (for_)+import Data.IORef (readIORef)+import Data.Maybe (isNothing) import Test.GeneralBracket (test_generalBracket)+import Test.RunPureEff+ ( assertInterruptedBracketOutcome,+ isClean,+ isPoisoned,+ isRanAtLeastTwice,+ test_runPureEffAsyncSafeReapsWorker,+ ) import Test.SpecH (SpecH, assertEqual, runSpecH)+import Test.ThrowCatch (test_throwCatch) import Prelude hiding (break, read) main :: IO ()@@ -15,6 +27,30 @@ runSpecH io $ \y -> do let assertEqual' = assertEqual y + assertInterruptedBracketOutcome+ io+ y+ "runPureEff retains bracket's rethrown exception"+ isPoisoned+ runPureEff+ assertInterruptedBracketOutcome+ io+ y+ "runPureEffAsyncSafe survives an interrupted bracket"+ isClean+ runPureEffAsyncSafe+ assertInterruptedBracketOutcome+ io+ y+ "runPureEffAsyncSafeRestarting restarts interrupted work"+ isRanAtLeastTwice+ runPureEffAsyncSafeRestarting+ workerException <- effIO io test_runPureEffAsyncSafeReapsWorker+ assertEqual'+ "runPureEffAsyncSafe worker receives ThreadKilled after result thunk GC"+ (Just ThreadKilled)+ workerException+ assertEqual' "oddsUntilFirstGreaterThan5" oddsUntilFirstGreaterThan5 [1, 3, 5, 7] assertEqual' "index 1" ([0, 1, 2, 3] !? 2) (Just 2) assertEqual' "index 2" ([0, 1, 2, 3] !? 4) Nothing@@ -34,11 +70,23 @@ "List" (runPureEff (yieldToList (listEff ([20, 30, 40], "Hello")))) ([20, 30, 40], "Hello")+ assertEqual'+ "Pure list"+ ( yieldToPureList $ \y -> do+ yield y 20+ yield y 30+ pure "Hello"+ )+ ([20, 30], "Hello") test_localInHandler y+ test_readerCleanup y test_generalBracket io y+ test_throwCatch y test_streamConsumeReader y test_streamConsumeHandleReader y+ test_unliftIOReader io y+ test_askCapabilityEscape y (!?) :: [a] -> Int -> Maybe a xs !? i = runPureEff $@@ -84,15 +132,34 @@ for_ as (yield y) pure r +test_readerCleanup :: (e <: es) => SpecH e -> Eff es ()+test_readerCleanup y = runReader @Int 1 $ \outer -> do+ for_ [False, True] $ \abort -> do+ key <- withEarlyReturn $ \ex ->+ runReader @Int 2 $ \(MkReader key) ->+ if abort then returnEarly ex key else pure key+ do+ -- Use the internals to check a property that cannot be tested without them.+ cleanedUp <- UnsafeMkEff $ \vault -> do+ contents <- readIORef vault+ pure (isNothing (Vault.lookup key contents))+ assertEqual+ y+ "Reader key released on normal and exceptional exit"+ True+ cleanedUp+ do+ outerValue <- ask outer+ assertEqual y "Outer Reader survives inner cleanup" 1 outerValue+ test_localInHandler :: (e <: es) => SpecH e -> Eff es () test_localInHandler y = runReader "global" $ \re -> forEach (\y2 -> local re (const "local") (yield y2 ())) (\() -> assertEqual y "Reader local" "local" =<< ask re) --- This test confirms the buggy behavior reported in------ https://github.com/tomjaguarpaw/bluefin/issues/98+-- local run in one branch of a streamConsume should not affect ask in+-- the other branch. test_streamConsumeReader :: (e <: es) => SpecH e -> Eff es () test_streamConsumeReader spech = do runReader @Int 0 $ \r -> do@@ -102,23 +169,23 @@ let check i = assertEqual spech "Reader local" i =<< ask r check 0 s- check (-100) -- Should be 0+ check 0 s- check (-200) -- Should be 0+ check 0 local r (+ 1) $ do- check (-199) -- Should be 1+ check 1 s- check (-299) -- Should be 1+ check 1 local r (+ 1) $ do- check (-298) -- Should be 2+ check 2 s- check (-398) -- Should be 2- check (-299) -- Should be 1+ check 2+ check 1 s- check (-299) -- Should be 1- check (-200) -- Should be 0+ check 1+ check 0 s- check (-200) -- Should be 0+ check 0 ) ( \a -> do let p = await a@@ -133,9 +200,8 @@ forever p ) --- This test confirms the buggy behavior reported in------ https://github.com/tomjaguarpaw/bluefin/issues/98+-- localHandle run in one branch of a streamConsume should not affect+-- asksHandle in the other branch. test_streamConsumeHandleReader :: (e <: es) => SpecH e -> Eff es () test_streamConsumeHandleReader spech = do runConstEffect @Int 0 $ \ce ->@@ -144,11 +210,11 @@ ( \y -> do let s = yield y () let check i = do- MkConstEffect i' <- askHandle r- assertEqual spech "HandleReader local" i i'+ asksHandle r $ \(MkConstEffect i') -> do+ assertEqual spech "HandleReader local" i i' check 0 s- check (-100) -- Should be 0+ check 0 ) ( \a -> do let p = await a@@ -156,3 +222,35 @@ localHandle r (\(MkConstEffect i) -> MkConstEffect (subtract 100 i)) $ do forever p )++-- Reader should interact well with withEffToIO_+test_unliftIOReader :: (e1 <: es, e2 <: es) => IOE e1 -> SpecH e2 -> Eff es ()+test_unliftIOReader io spech = do+ let foo :: (Int -> IO ()) -> (forall r. Int -> IO r -> IO r) -> IO ()+ foo myYield mySetLocal = do+ myYield 0+ mySetLocal 1 $ do+ myYield 1+ mySetLocal 2 $ do+ myYield 2++ runReader @Int 0 $ \r -> do+ withEffToIO_ io $ \effToIO -> do+ foo+ ( \i -> effToIO $ do+ i' <- ask r+ assertEqual spech "myLocal" i i'+ )+ (\x -> effToIO . local r (const x) . effIO io)++test_askCapabilityEscape :: (e <: es) => SpecH e -> Eff es ()+test_askCapabilityEscape y = runConstEffect False $ \cFalse ->+ runAskCapability cFalse $ \(ac :: HandleReader (ConstEffect Bool) e) -> do+ -- We should not be allowed to escape `escaped` like this. A+ -- future version of Bluefin should fix this by removing+ -- `askCapability`.+ escaped <- runConstEffect True $ \cTrue -> do+ localCapability ac (const (mapHandle cTrue)) $ do+ useImpl (askCapability @_ @e ac)+ let MkConstEffect escapedValue = escaped+ assertEqual y "askCapability escape" True escapedValue
+ test/Test/RunPureEff.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Test.RunPureEff where++import Bluefin.Internal+import Control.Concurrent (threadDelay, throwTo)+import Control.Concurrent.Async (asyncThreadId, waitCatch, withAsync)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryPutMVar)+import Control.Exception (AsyncException (ThreadKilled), SomeException, evaluate)+import Control.Exception qualified as Exception+import Control.Monad (forever, unless)+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)+import System.Mem (performMajorGC)+import System.Timeout (timeout)+import Test.SpecH (SpecH, assertSatisfies)++-- Interrupt a thread while it forces a shared thunk which runs inside+-- a bracket, then force the thunk again and check from what point the+-- computation resumed.+test_runPureEffAsyncSafeSurvivesInterruptedBracket ::+ (forall r. (forall e. Eff e r) -> r) ->+ IO InterruptedBracketResult+test_runPureEffAsyncSafeSurvivesInterruptedBracket run = do+ started <- newEmptyMVar+ continue <- newEmptyMVar+ forceThunk <- do+ modified <- newIORef False+ ref <- newIORef $ run $ bracket (pure ()) (\() -> pure ()) $ \() -> do+ let prog = do+ previouslyModified <-+ atomicModifyIORef' modified $ \previous ->+ (True, previous)+ -- Unless the IORef was previously modified, this is our+ -- first run. Therefore, wait for the caller to unblock us,+ -- and throw us an asynchronous exception.+ unless previouslyModified $ do+ _ <- tryPutMVar started ()+ takeMVar continue+ pure previouslyModified+ unsafeProvideIO (\io -> effIO io prog)+ pure (evaluate =<< readIORef ref)+ interrupted <- withAsync forceThunk $ \worker -> do+ takeMVar started+ throwTo (asyncThreadId worker) ThreadKilled+ waitCatch worker+ case interrupted of+ Left eInterrupted+ | Just ThreadKilled <- Exception.fromException eInterrupted -> do+ resumed <- do+ -- If the first evaluation is resumed, it will need+ -- unblocking. If evaluation started from scratch it+ -- won't block on continue anyway, because+ -- previouslyModified is true.+ putMVar continue ()+ Exception.try @SomeException $ do+ forceThunk+ case resumed of+ Left eResumed+ | Just ThreadKilled <- Exception.fromException eResumed ->+ pure ThunkPoisoned+ | otherwise ->+ pure (UnexpectedException eResumed)+ Right previouslyModified ->+ pure $ case previouslyModified of+ False -> ThunkClean+ True -> RanAtLeastTwice+ | otherwise -> pure (UnexpectedException eInterrupted)+ Right _ -> pure FinishedEarly++-- Drop the result thunk after cancelling its forcing thread, then collect it+-- and check that its weak finalizer kills the computation worker.+test_runPureEffAsyncSafeReapsWorker :: IO (Maybe AsyncException)+test_runPureEffAsyncSafeReapsWorker = do+ started <- newEmptyMVar+ caught <- newEmptyMVar+ (release, forceThunk) <- do+ shared <- newIORef @(Maybe ()) $ Just $ runPureEffAsyncSafe $ do+ unsafeProvideIO $ \io -> do+ effIO io $ do+ putMVar started ()+ Exception.handle @SomeException+ (putMVar caught)+ (forever (threadDelay 1_000_000))+ pure+ ( writeIORef shared Nothing,+ maybe (fail "result thunk released") evaluate =<< readIORef shared+ )+ withAsync forceThunk $ \forcingThunk -> do+ takeMVar started+ throwTo (asyncThreadId forcingThunk) ThreadKilled+ waitCatch forcingThunk >>= \case+ Right () ->+ fail "forcing thunk completed instead of being killed"+ Left e+ | -- We expect forcingThurk to be killed by ThreadKilled,+ -- because that's what we just threw to it.+ Just ThreadKilled <- Exception.fromException e ->+ pure ()+ | -- If we were killed by anything else, that should be+ -- reported+ otherwise ->+ Exception.throwIO e++ release+ performMajorGC+ caughtException <- timeout 1000000 (takeMVar caught)+ pure (Exception.fromException =<< caughtException)++data InterruptedBracketResult+ = FinishedEarly+ | UnexpectedException !SomeException+ | ThunkPoisoned+ | ThunkClean+ | RanAtLeastTwice+ deriving stock (Show)++isClean :: InterruptedBracketResult -> Bool+isClean = \case+ ThunkClean -> True+ _ -> False++isPoisoned :: InterruptedBracketResult -> Bool+isPoisoned = \case+ ThunkPoisoned -> True+ _ -> False++isRanAtLeastTwice :: InterruptedBracketResult -> Bool+isRanAtLeastTwice = \case+ RanAtLeastTwice -> True+ _ -> False++assertInterruptedBracketOutcome ::+ (e1 <: es, e2 <: es) =>+ IOE e1 ->+ SpecH e2 ->+ String ->+ (InterruptedBracketResult -> Bool) ->+ (forall r. (forall e. Eff e r) -> r) ->+ Eff es ()+assertInterruptedBracketOutcome io y name predicate run = do+ actual <- effIO io $ test_runPureEffAsyncSafeSurvivesInterruptedBracket run+ assertSatisfies y name predicate actual
test/Test/SpecH.hs view
@@ -23,6 +23,23 @@ yield y2 ("But got: " ++ show c2) ) +assertSatisfies ::+ (e <: es, Show a) =>+ SpecH e ->+ String ->+ (a -> Bool) ->+ a ->+ Eff es ()+assertSatisfies y n predicate actual =+ yield+ y+ ( n,+ if predicate actual+ then Nothing+ else Just $ dslBuilder $ \y2 ->+ yield y2 ("Predicate was not satisfied by: " ++ show actual)+ )+ type SpecInfo r = DslBuilder (Stream String) r runTests ::
+ test/Test/ThrowCatch.hs view
@@ -0,0 +1,29 @@+module Test.ThrowCatch where++import Bluefin.Internal+import Bluefin.Internal.Capability.ThrowCatch qualified as ThrowCatch+import Test.SpecH (SpecH, assertEqual)++test_throwCatch :: (e <: es) => SpecH e -> Eff es ()+test_throwCatch y = do+ assertEqual+ y+ "ThrowCatch.try catches a thrown exception"+ (Left @String @() "caught")+ (runPureEff (ThrowCatch.try $ \ex -> ThrowCatch.throw ex "caught"))+ assertEqual+ y+ "ThrowCatch.try returns a successful result"+ (Right @String @Int 42)+ (runPureEff (ThrowCatch.try $ \_ -> pure 42))+ assertEqual+ y+ "ThrowCatch.localTry catches a thrown exception"+ (Left @String @() "outer")+ ( runPureEff $ ThrowCatch.try $ \ex -> do+ localResult <- ThrowCatch.localTry ex (ThrowCatch.throw ex "inner")+ ThrowCatch.throw ex $ case localResult of+ Left "inner" -> "outer"+ Left _ -> "unexpected local exception"+ Right () -> "localTry did not catch"+ )