effectful-core 2.2.2.2 → 2.3.0.0
raw patch · 15 files changed
+504/−58 lines, 15 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Effectful.Internal.Unlift: ephemeralConcUnlift :: HasCallStack => Int -> ((forall r. m r -> IO r) -> IO a) -> Env es -> (forall r. m r -> Env es -> IO r) -> IO a
- Effectful.Internal.Unlift: persistentConcUnlift :: HasCallStack => Bool -> Int -> ((forall r. m r -> IO r) -> IO a) -> Env es -> (forall r. m r -> Env es -> IO r) -> IO a
+ Effectful.Error.Dynamic: runErrorNoCallStackWith :: (e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
+ Effectful.Error.Dynamic: runErrorWith :: (CallStack -> e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
+ Effectful.Error.Static: runErrorNoCallStackWith :: (e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
+ Effectful.Error.Static: runErrorWith :: (CallStack -> e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
+ Effectful.Internal.Utils: data Unique
+ Effectful.Internal.Utils: instance GHC.Classes.Eq Effectful.Internal.Utils.Unique
+ Effectful.Internal.Utils: newUnique :: IO Unique
+ Effectful.Labeled: data Labeled (label :: k) (e :: Effect) :: Effect
+ Effectful.Labeled: labeled :: forall label e es a. Labeled label e :> es => Eff (e : es) a -> Eff es a
+ Effectful.Labeled: runLabeled :: forall label e es a b. (Eff (e : es) a -> Eff es b) -> Eff (Labeled label e : es) a -> Eff es b
+ Effectful.Provider: data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect
+ Effectful.Provider: provide :: Provider e () f :> es => Eff (e : es) a -> Eff es (f a)
+ Effectful.Provider: provideWith :: Provider e input f :> es => input -> Eff (e : es) a -> Eff es (f a)
+ Effectful.Provider: provideWith_ :: Provider_ e input :> es => input -> Eff (e : es) a -> Eff es a
+ Effectful.Provider: provide_ :: Provider_ e () :> es => Eff (e : es) a -> Eff es a
+ Effectful.Provider: runProvider :: (forall r. input -> Eff (e : es) r -> Eff es (f r)) -> Eff (Provider e input f : es) a -> Eff es a
+ Effectful.Provider: runProvider_ :: (forall r. input -> Eff (e : es) r -> Eff es r) -> Eff (Provider_ e input : es) a -> Eff es a
+ Effectful.Provider: type Provider_ e input = Provider e input Identity
- Effectful: withEffToIO :: (HasCallStack, IOE :> es) => ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
+ Effectful: withEffToIO :: (HasCallStack, IOE :> es) => UnliftStrategy -> ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
- Effectful.Internal.Monad: withEffToIO :: (HasCallStack, IOE :> es) => ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
+ Effectful.Internal.Monad: withEffToIO :: (HasCallStack, IOE :> es) => UnliftStrategy -> ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
Files
- CHANGELOG.md +12/−0
- README.md +1/−1
- effectful-core.cabal +5/−2
- src/Effectful.hs +4/−4
- src/Effectful/Dispatch/Dynamic.hs +49/−0
- src/Effectful/Dispatch/Static.hs +1/−1
- src/Effectful/Dispatch/Static/Primitive.hs +2/−2
- src/Effectful/Dispatch/Static/Unsafe.hs +21/−8
- src/Effectful/Error/Dynamic.hs +24/−0
- src/Effectful/Error/Static.hs +23/−1
- src/Effectful/Internal/Monad.hs +45/−25
- src/Effectful/Internal/Unlift.hs +12/−11
- src/Effectful/Internal/Utils.hs +19/−3
- src/Effectful/Labeled.hs +87/−0
- src/Effectful/Provider.hs +199/−0
CHANGELOG.md view
@@ -1,3 +1,15 @@+# effectful-core-2.3.0.0 (2023-09-13)+* Deprecate `withConcEffToIO`.+* Make `withEffToIO` take an explicit unlifting strategy for the sake of+ consistency with unlifting functions from `Effectful.Dispatch.Dynamic` and+ easier to understand API.+* Add support for turning an effect handler into an effectful operation via the+ `Provider` effect.+* Add `runErrorWith` and `runErrorNoCallStackWith` to `Effectful.Error.Dynamic`+ and `Effectful.Error.Static`.+* Add support for having multiple effects of the same type in scope via the+ `Labeled` effect.+ # effectful-core-2.2.2.2 (2023-03-13) * Allow `inject` to turn a monomorphic effect stack into a polymorphic one. * Use C sources only with GHC < 9.
README.md view
@@ -38,7 +38,7 @@ [freer-simple](https://hackage.haskell.org/package/freer-simple), [fused-effects](https://hackage.haskell.org/package/fused-effects), [polysemy](https://hackage.haskell.org/package/polysemy),-[eff](https://github.com/hasura/eff) and probably a few more.+[eff](https://github.com/lexi-lambda/eff) and probably a few more. It needs to be noted that of all of them only the work-in-progress `eff` library is a promising proposition because of reasonable performance characteristics
effectful-core.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 build-type: Simple name: effectful-core-version: 2.2.2.2+version: 2.3.0.0 license: BSD-3-Clause license-file: LICENSE category: Control@@ -21,7 +21,8 @@ CHANGELOG.md README.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.2+ || ==9.8.1 bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head@@ -85,8 +86,10 @@ Effectful.Internal.Monad Effectful.Internal.Unlift Effectful.Internal.Utils+ Effectful.Labeled Effectful.NonDet Effectful.Prim+ Effectful.Provider Effectful.Reader.Dynamic Effectful.Reader.Static Effectful.State.Dynamic
src/Effectful.hs view
@@ -44,8 +44,8 @@ , Limit(..) , unliftStrategy , withUnliftStrategy- , withEffToIO , withSeqEffToIO+ , withEffToIO , withConcEffToIO -- ** Lifting@@ -160,9 +160,9 @@ -- If a library operates in 'IO', there are a couple of ways to integrate it. -- -- The easiest way is to use its functions selectively in the 'Eff' monad with--- the help of 'liftIO' or 'withEffToIO' / 'withRunInIO'. However, this is not--- particularly robust, since it vastly broadens the scope in which the 'IOE'--- effect is needed (not to mention that explicit lifting is annoying).+-- the help of 'liftIO' or 'withEffToIO'. However, this is not particularly+-- robust, since it vastly broadens the scope in which the 'IOE' effect is+-- needed (not to mention that explicit lifting is annoying). -- -- A somewhat better approach is to create a dummy static effect with -- lightweight wrappers of the library functions. As an example have a look at
src/Effectful/Dispatch/Dynamic.hs view
@@ -13,6 +13,9 @@ -- ** Integration with @mtl@ style effects -- $integration + -- *** Functional dependencies+ -- $mtl-fundeps+ -- * Sending operations to the handler send @@ -343,6 +346,52 @@ -- >>> runEff . runDummyRNG $ randomString 3 -- "777" --++-- $mtl-fundeps+--+-- For dealing with classes that employ functional dependencies an additional+-- trick is needed.+--+-- Consider the following:+--+-- >>> :set -XFunctionalDependencies+--+-- >>> :{+-- class Monad m => MonadInput i m | i -> m where+-- input :: m i+-- :}+--+-- An attempt to define the instance as in the example above leads to violation+-- of the liberal coverage condition:+--+-- >>> :{+-- instance Reader i :> es => MonadInput i (Eff es) where+-- input = ask+-- :}+-- ...+-- ...Illegal instance declaration for ‘MonadInput i (Eff es)’...+-- ... The liberal coverage condition fails in class ‘MonadInput’...+-- ... for functional dependency: ‘i -> m’...+-- ...+--+-- However, there exists a [dirty+-- trick](https://www.youtube.com/watch?v=ZXtdd8e7CQQ) for bypassing the+-- coverage condition, i.e. including the instance head in the context:+--+-- >>> :{+-- instance (MonadInput i (Eff es), Reader i :> es) => MonadInput i (Eff es) where+-- input = ask+-- :}+--+-- Now the @MonadInput@ class can be used with the 'Eff' monad:+--+-- >>> :{+-- double :: MonadInput Int m => m Int+-- double = (+) <$> input <*> input+-- :}+--+-- >>> runPureEff . runReader @Int 3 $ double+-- 6 ---------------------------------------- -- Handling effects
src/Effectful/Dispatch/Static.hs view
@@ -48,7 +48,7 @@ -- -- Unlike dynamically dispatched effects, statically dispatched effects have a -- single, set interpretation that cannot be changed at runtime, which makes--- them useful in specific scenatios. For example:+-- them useful in specific scenarios. For example: -- -- * If you'd like to ensure that a specific effect will behave in a certain way -- at all times, using a statically dispatched version is the only way to
src/Effectful/Dispatch/Static/Primitive.hs view
@@ -5,8 +5,8 @@ -- sufficient. -- -- /Warning:/ playing the so called "type tetris" with functions from this--- module is not enough. Their misuse might lead to memory corruption or--- segmentation faults, so make sure you understand what you're doing.+-- module is not enough. Their misuse might lead to data races or internal+-- consistency check failures, so make sure you understand what you're doing. module Effectful.Dispatch.Static.Primitive ( -- * The environment Env
src/Effectful/Dispatch/Static/Unsafe.hs view
@@ -14,28 +14,41 @@ -- -- @'Eff' es a -> 'Eff' es b@ ----- This function is __highly unsafe__ because:+-- This function is __really unsafe__ because: -- -- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' -- computations. ----- - The 'IO' computation must not run its argument in a different thread, but--- it's not checked anywhere.+-- - The 'IO' computation must run its argument in a way that's perceived as+-- sequential to the outside observer, e.g. in the same thread or in a worker+-- thread that finishes before the argument is run again. ----- __If you disregard the second point, segmentation faults await.__+-- __Warning:__ if you disregard the second point, you will experience weird+-- bugs, data races or internal consistency check failures.+--+-- When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially+-- since this version saves only a simple safety check per call of+-- @reallyUnsafeLiftMapIO f@. reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es) -- | Create an unlifting function. ----- This function is __highly unsafe__ because:+-- This function is __really unsafe__ because: -- -- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' -- computations. ----- - Unlifted 'Eff' computations must not be run in a thread distinct from the--- caller of 'reallyUnsafeUnliftIO', but it's not checked anywhere.+-- - Unlifted 'Eff' computations must be run in a way that's perceived as+-- sequential to the outside observer, e.g. in the same thread as the caller+-- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before+-- another unlifted computation is run. ----- __If you disregard the second point, segmentation faults await.__+-- __Warning:__ if you disregard the second point, you will experience weird+-- bugs, data races or internal consistency check failures.+--+-- When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially+-- since this version saves only a simple safety check per call of the unlifting+-- function. reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)
src/Effectful/Error/Dynamic.hs view
@@ -9,7 +9,9 @@ -- ** Handlers , runError+ , runErrorWith , runErrorNoCallStack+ , runErrorNoCallStackWith -- ** Operations , throwError@@ -46,12 +48,34 @@ CatchError m h -> localSeqUnlift env $ \unlift -> do E.catchError (unlift m) (\cs -> unlift . h cs) +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler.+runErrorWith+ :: (E.CallStack -> e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorWith handler m = runError m >>= \case+ Left (cs, e) -> handler cs e+ Right a -> pure a+ -- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an -- error discard the 'E.CallStack'. runErrorNoCallStack :: Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError++-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler. In case of an error discard the 'CallStack'.+runErrorNoCallStackWith+ :: (e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case+ Left e -> handler e+ Right a -> pure a -- | Throw an error of type @e@. throwError
src/Effectful/Error/Static.hs view
@@ -81,7 +81,9 @@ -- ** Handlers , runError+ , runErrorWith , runErrorNoCallStack+ , runErrorNoCallStackWith -- ** Operations , throwError@@ -97,7 +99,6 @@ ) where import Control.Exception-import Data.Unique import GHC.Stack import Effectful@@ -128,12 +129,33 @@ Left ex -> tryHandler ex eid (\cs e -> Left (cs, e)) $ throwIO ex +-- | Handle errors of type @e@ with a specific error handler.+runErrorWith+ :: (CallStack -> e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorWith handler m = runError m >>= \case+ Left (cs, e) -> handler cs e+ Right a -> pure a+ -- | Handle errors of type @e@. In case of an error discard the 'CallStack'. runErrorNoCallStack :: forall e es a . Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError++-- | Handle errors of type @e@ with a specific error handler. In case of an+-- error discard the 'CallStack'.+runErrorNoCallStackWith+ :: (e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case+ Left e -> handler e+ Right a -> pure a -- | Throw an error of type @e@. throwError
src/Effectful/Internal/Monad.hs view
@@ -44,8 +44,8 @@ , Limit(..) , unliftStrategy , withUnliftStrategy- , withEffToIO , withSeqEffToIO+ , withEffToIO , withConcEffToIO -- ** Low-level unlifts@@ -164,38 +164,45 @@ -- Unlifting IO -- | Get the current 'UnliftStrategy'.+--+-- /Note:/ this strategy is implicitly used by the 'MonadUnliftIO' and+-- 'MonadBaseControl' instance for 'Eff'. unliftStrategy :: IOE :> es => Eff es UnliftStrategy unliftStrategy = do IOE unlift <- getStaticRep pure unlift --- | Locally override the 'UnliftStrategy' with the given value.+-- | Locally override the current 'UnliftStrategy' with the given value. withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a withUnliftStrategy unlift = localStaticRep $ \_ -> IOE unlift --- | Create an unlifting function with the current 'UnliftStrategy'.+-- | Create an unlifting function with the 'SeqUnlift' strategy. For the general+-- version see 'withEffToIO'. ----- This function is equivalent to 'Effectful.withRunInIO', but has a--- 'HasCallStack' constraint for accurate stack traces in case an insufficiently--- powerful 'UnliftStrategy' is used and the unlifting function fails.-withEffToIO+-- /Note:/ usage of this function is preferrable to 'Effectful.withRunInIO'+-- because of explicit unlifting strategy and better error reporting.+--+-- @since 2.2.2.0+withSeqEffToIO :: (HasCallStack, IOE :> es) => ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-withEffToIO f = unliftStrategy >>= \case- SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f- ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b f+withSeqEffToIO f = unsafeEff $ \es -> seqUnliftIO es f --- | Create an unlifting function with the 'SeqUnlift' strategy.+-- | Create an unlifting function with the given strategy. ----- @since 2.2.2.0-withSeqEffToIO+-- /Note:/ usage of this function is preferrable to 'Effectful.withRunInIO'+-- because of explicit unlifting strategy and better error reporting.+withEffToIO :: (HasCallStack, IOE :> es)- => ((forall r. Eff es r -> IO r) -> IO a)+ => UnliftStrategy+ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-withSeqEffToIO f = unsafeEff $ \es -> seqUnliftIO es f+withEffToIO strategy f = case strategy of+ SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f+ ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b f -- | Create an unlifting function with the 'ConcUnlift' strategy. --@@ -209,6 +216,7 @@ -> Eff es a withConcEffToIO persistence limit f = unsafeEff $ \es -> concUnliftIO es persistence limit f+{-# DEPRECATED withConcEffToIO "Use withEffToIO with the appropriate strategy." #-} -- | Create an unlifting function with the 'SeqUnlift' strategy. seqUnliftIO@@ -258,7 +266,7 @@ ---------------------------------------- -- NonDet --- | Provide the ability to use the 'Alternative' and 'MonadPlus' instance of+-- | Provide the ability to use the 'Alternative' and 'MonadPlus' instance for -- 'Eff'. -- -- @since 2.2.0.0@@ -305,7 +313,7 @@ ---------------------------------------- -- Fail --- | Provide the ability to use the 'MonadFail' instance of 'Eff'.+-- | Provide the ability to use the 'MonadFail' instance for 'Eff'. data Fail :: Effect where Fail :: String -> Fail m a @@ -336,20 +344,32 @@ instance IOE :> es => MonadIO (Eff es) where liftIO = unsafeEff_ --- | Use 'withEffToIO' if you want accurate stack traces on errors.+-- | Instance included for compatibility with existing code.+--+-- Usage of 'withEffToIO' is preferrable as it allows specifying the+-- 'UnliftStrategy' on a case-by-case basis and has better error reporting.+--+-- /Note:/ the unlifting strategy for 'withRunInIO' is taken from the 'IOE'+-- context (see 'unliftStrategy'). instance IOE :> es => MonadUnliftIO (Eff es) where- withRunInIO = withEffToIO+ withRunInIO k = unliftStrategy >>= (`withEffToIO` k) --- | Instance included for compatibility with existing code, usage of 'liftIO'--- is preferrable.+-- | Instance included for compatibility with existing code.+--+-- Usage of 'liftIO' is preferrable as it's a standard. instance IOE :> es => MonadBase IO (Eff es) where liftBase = unsafeEff_ --- | Instance included for compatibility with existing code, usage of--- 'Effectful.withRunInIO' is preferrable.+-- | Instance included for compatibility with existing code.+--+-- Usage of 'withEffToIO' is preferrable as it allows specifying the+-- 'UnliftStrategy' on a case-by-case basis and has better error reporting.+--+-- /Note:/ the unlifting strategy for 'liftBaseWith' is taken from the 'IOE'+-- context (see 'unliftStrategy'). instance IOE :> es => MonadBaseControl IO (Eff es) where type StM (Eff es) a = a- liftBaseWith = withEffToIO+ liftBaseWith k = unliftStrategy >>= (`withEffToIO` k) restoreM = pure ----------------------------------------@@ -504,7 +524,7 @@ send :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => e (Eff es) a- -- ^ The effect.+ -- ^ The operation. -> Eff es a send op = unsafeEff $ \es -> do Handler handlerEs handle <- getEnv es
src/Effectful/Internal/Unlift.hs view
@@ -14,8 +14,6 @@ -- * Unlifting functions , seqUnlift , concUnlift- , ephemeralConcUnlift- , persistentConcUnlift ) where import Control.Concurrent@@ -36,17 +34,17 @@ -- Unlift strategies -- | The strategy to use when unlifting 'Effectful.Eff' computations via--- 'Effectful.withEffToIO', 'Effectful.withRunInIO' or the--- 'Effectful.Dispatch.Dynamic.localUnlift' family.+-- 'Effectful.withEffToIO' or the 'Effectful.Dispatch.Dynamic.localUnlift'+-- family. data UnliftStrategy = SeqUnlift- -- ^ The fastest strategy and a default setting for t'Effectful.IOE'. An- -- attempt to call the unlifting function in threads distinct from its creator- -- will result in a runtime error.+ -- ^ The sequential strategy is the fastest and a default setting for+ -- t'Effectful.IOE'. Any attempt of calling the unlifting function in threads+ -- distinct from its creator will result in a runtime error. | ConcUnlift !Persistence !Limit- -- ^ A strategy that makes it possible for the unlifting function to be called- -- in threads distinct from its creator. See 'Persistence' and 'Limit'- -- settings for more information.+ -- ^ The concurrent strategy makes it possible for the unlifting function to+ -- be called in threads distinct from its creator. See 'Persistence' and+ -- 'Limit' settings for more information. deriving (Eq, Generic, Ord, Show) -- | Persistence setting for the 'ConcUnlift' strategy.@@ -108,7 +106,7 @@ $ "If you want to use the unlifting function to run Eff computations " ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." --- | Concurrent unlift for various strategies and limits.+-- | Concurrent unlift. concUnlift :: HasCallStack => Persistence@@ -125,6 +123,9 @@ persistentConcUnlift False threads k concUnlift Persistent Unlimited k = persistentConcUnlift True maxBound k++----------------------------------------+-- Internal -- | Concurrent unlift that doesn't preserve the environment between calls to -- the unlifting function in threads other than its creator.
src/Effectful/Internal/Utils.hs view
@@ -27,13 +27,18 @@ , readMVar' , modifyMVar' , modifyMVar_'++ -- * Unique+ , Unique+ , newUnique ) where import Control.Concurrent.MVar import Control.Exception import Data.IORef+import Data.Primitive.ByteArray import GHC.Conc.Sync (ThreadId(..))-import GHC.Exts (Addr#, Any, ThreadId#, unsafeCoerce#)+import GHC.Exts (Addr#, Any, RealWorld, ThreadId#, unsafeCoerce#) import Unsafe.Coerce (unsafeCoerce) #if __GLASGOW_HASKELL__ >= 904@@ -145,10 +150,21 @@ modifyMVar' (MVar' var) action = modifyMVar var $ \a0 -> do (a, r) <- action a0 a `seq` pure (a, r)-{-# INLINE modifyMVar' #-} modifyMVar_' :: MVar' a -> (a -> IO a) -> IO () modifyMVar_' (MVar' var) action = modifyMVar_ var $ \a0 -> do a <- action a0 a `seq` pure a-{-# INLINE modifyMVar_' #-}++----------------------------------------++-- | A unique with no possibility for CAS contention.+--+-- Credits for this go to Edward Kmett.+newtype Unique = Unique (MutableByteArray RealWorld)++instance Eq Unique where+ Unique a == Unique b = sameMutableByteArray a b++newUnique :: IO Unique+newUnique = Unique <$> newByteArray 0
+ src/Effectful/Labeled.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}+-- | Labeled effects.+module Effectful.Labeled+ ( -- * Example+ -- $example++ -- * Effect+ Labeled++ -- ** Handlers+ , runLabeled++ -- ** Operations+ , labeled+ ) where++import Unsafe.Coerce (unsafeCoerce)++import Effectful+import Effectful.Dispatch.Static++-- $example+--+-- An effect can be assigned multiple labels and you can have all of them+-- available at the same time.+--+-- >>> import Effectful.Reader.Static+--+-- >>> :{+-- action+-- :: ( Labeled "a" (Reader String) :> es+-- , Labeled "b" (Reader String) :> es+-- , Reader String :> es+-- )+-- => Eff es String+-- action = do+-- a <- labeled @"b" @(Reader String) $ do+-- labeled @"a" @(Reader String) $ do+-- ask+-- b <- labeled @"b" @(Reader String) $ do+-- ask+-- pure $ a ++ b+-- :}+--+-- >>> :{+-- runPureEff @String+-- . runLabeled @"a" (runReader "a")+-- . runLabeled @"b" (runReader "b")+-- . runReader "c"+-- $ action+-- :}+-- "ab"++-- | Assign a label to an effect.+data Labeled (label :: k) (e :: Effect) :: Effect++type instance DispatchOf (Labeled label e) = Static NoSideEffects++data instance StaticRep (Labeled label e)++-- | Run a 'Labeled' effect with a given effect handler.+runLabeled+ :: forall label e es a b+ . (Eff (e : es) a -> Eff es b)+ -- ^ The effect handler.+ -> Eff (Labeled label e : es) a+ -> Eff es b+runLabeled runE m = runE (fromLabeled m)++-- | Bring an effect into scope to be able to run its operations.+labeled+ :: forall label e es a+ . Labeled label e :> es+ => Eff (e : es) a+ -- ^ The action using the effect.+ -> Eff es a+labeled m = subsume @(Labeled label e) (toLabeled m)++----------------------------------------+-- Helpers++fromLabeled :: Eff (Labeled label e : es) a -> Eff (e : es) a+fromLabeled = unsafeCoerce++toLabeled :: Eff (e : es) a -> Eff (Labeled label e : es) a+toLabeled = unsafeCoerce
+ src/Effectful/Provider.hs view
@@ -0,0 +1,199 @@+-- | Turn an effect handler into an effectful operation.+module Effectful.Provider+ ( -- * Example+ -- $example++ -- * Effect+ Provider+ , Provider_++ -- ** Handlers+ , runProvider+ , runProvider_++ -- ** Operations+ , provide+ , provide_+ , provideWith+ , provideWith_+ ) where++import Control.Monad+import Data.Coerce+import Data.Functor.Identity+import Data.Kind (Type)+import Data.Primitive.PrimArray++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Env (Env(..))+import Effectful.Internal.Utils++-- $example+--+-- >>> import Control.Monad.IO.Class+-- >>> import Effectful.Dispatch.Dynamic+-- >>> import Effectful.State.Static.Local+-- >>> import qualified Data.Map.Strict as M+--+-- Given an effect:+--+-- >>> :{+-- data Write :: Effect where+-- Write :: String -> Write m ()+-- type instance DispatchOf Write = Dynamic+-- :}+--+-- >>> :{+-- write :: Write :> es => String -> Eff es ()+-- write = send . Write+-- :}+--+-- its handler can be turned into an effectful operation with the 'Provider'+-- effect:+--+-- >>> :{+-- action :: Provider_ Write FilePath :> es => Eff es ()+-- action = do+-- provideWith_ @Write "in.txt" $ do+-- write "hi"+-- write "there"+-- provideWith_ @Write "out.txt" $ do+-- write "good"+-- write "bye"+-- :}+--+-- Then, given multiple interpreters:+--+-- >>> :{+-- runWriteIO+-- :: IOE :> es+-- => FilePath+-- -> Eff (Write : es) a+-- -> Eff es a+-- runWriteIO fp = interpret $ \_ -> \case+-- Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg+-- :}+--+-- >>> :{+-- runWritePure+-- :: State (M.Map FilePath [String]) :> es+-- => FilePath+-- -> Eff (Write : es) a+-- -> Eff es a+-- runWritePure fp = interpret $ \_ -> \case+-- Write msg -> modify $ M.insertWith (++) fp [msg]+-- :}+--+-- @action@ can be supplied with either of them for the appropriate behavior:+--+-- >>> :{+-- runEff+-- . runProvider_ runWriteIO+-- $ action+-- :}+-- in.txt: hi+-- in.txt: there+-- out.txt: good+-- out.txt: bye+--+-- >>> :{+-- runPureEff+-- . fmap (fmap reverse)+-- . execState @(M.Map FilePath [String]) M.empty+-- . runProvider_ runWritePure+-- $ action+-- :}+-- fromList [("in.txt",["hi","there"]),("out.txt",["good","bye"])]++-- | Provide a way to run a handler of @e@ with a given @input@.+--+-- /Note:/ @f@ can be used to alter the return type of the effect handler. If+-- that's unnecessary, use 'Provider_'.+data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect++-- | A restricted variant of 'Provider' with unchanged return type of the effect+-- handler.+type Provider_ e input = Provider e input Identity++type instance DispatchOf (Provider e input f) = Static NoSideEffects++data instance StaticRep (Provider e input f) where+ Provider :: !(Env handlerEs)+ -> !(forall r. input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))+ -> StaticRep (Provider e input f)++-- | Run the 'Provider' effect with a given effect handler.+runProvider+ :: (forall r. input -> Eff (e : es) r -> Eff es (f r))+ -- ^ The effect handler.+ -> Eff (Provider e input f : es) a+ -> Eff es a+runProvider run m = unsafeEff $ \es0 -> do+ inlineBracket+ (consEnv (Provider es0 run) relinkProvider es0)+ unconsEnv+ (\es -> unEff m es)++-- | Run the 'Provider' effect with a given effect handler that doesn't change+-- its return type.+runProvider_+ :: (forall r. input -> Eff (e : es) r -> Eff es r)+ -- ^ The effect handler.+ -> Eff (Provider_ e input : es) a+ -> Eff es a+runProvider_ run = runProvider $ \input -> coerce . run input++-- | Run the effect handler.+provide :: Provider e () f :> es => Eff (e : es) a -> Eff es (f a)+provide = provideWith ()++-- | Run the effect handler with unchanged return type.+provide_ :: Provider_ e () :> es => Eff (e : es) a -> Eff es a+provide_ = provideWith_ ()++-- | Run the effect handler with a given input.+provideWith+ :: Provider e input f :> es+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es (f a)+provideWith input action = unsafeEff $ \es -> do+ Provider handlerEs run <- getEnv es+ (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do+ unEff action =<< copyRef eHandlerEs es++-- | Run the effect handler that doesn't change its return type with a given+-- input.+provideWith_+ :: Provider_ e input :> es+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es a+provideWith_ input = adapt . provideWith input+ where+ adapt :: Eff es (Identity a) -> Eff es a+ adapt = coerce++----------------------------------------+-- Helpers++relinkProvider :: Relinker StaticRep (Provider e input f)+relinkProvider = Relinker $ \relink (Provider handlerEs run) -> do+ newHandlerEs <- relink handlerEs+ pure $ Provider newHandlerEs run++copyRef :: Env (e : handlerEs) -> Env es -> IO (Env (e : es))+copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do+ when (hstorage /= storage) $ do+ error "storages do not match"+ let size = sizeofPrimArray refs0 - offset+ mrefs <- newPrimArray (size + 2)+ copyPrimArray mrefs 2 refs0 offset size+ writePrimArray mrefs 0 $ indexPrimArray hrefs hoffset+ writePrimArray mrefs 1 $ indexPrimArray hrefs (hoffset + 1)+ refs <- unsafeFreezePrimArray mrefs+ pure $ Env 0 refs storage