packages feed

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 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