mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
Rename Lift to Embed (#161)
* Move Polysemy.Internal.Lift to Polysemy.Lift.Type * Add Polysemy.Lift module and runLift interpreter * Add a Sandy reminder * Add explicit foralls and split type signature * Fix import spacing, for there is no "qualified" * Implement runIO in terms of runLift * Rename Lift -> Embed * Replace sendM with embed * Add a Sandy todo for embed version * Rename runEmbed and related runEmbedded (from IO) * runEmbedded -> runEmbeddedInIO * runEmbed -> runEmbedded * Update cabal
This commit is contained in:
parent
9bfb486769
commit
48b6768ad4
@ -91,10 +91,10 @@ data Teletype m a where
|
||||
|
||||
makeSem ''Teletype
|
||||
|
||||
runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a
|
||||
runTeletypeIO :: Member (Embed IO) r => Sem (Teletype ': r) a -> Sem r a
|
||||
runTeletypeIO = interpret $ \case
|
||||
ReadTTY -> sendM getLine
|
||||
WriteTTY msg -> sendM $ putStrLn msg
|
||||
ReadTTY -> embed getLine
|
||||
WriteTTY msg -> embed $ putStrLn msg
|
||||
|
||||
runTeletypePure :: [String] -> Sem (Teletype ': r) a -> Sem r ([String], a)
|
||||
runTeletypePure i
|
||||
@ -121,7 +121,7 @@ pureOutput :: [String] -> [String]
|
||||
pureOutput = fst . run . echoPure
|
||||
|
||||
-- Now let's do things
|
||||
echoIO :: Sem '[Lift IO] ()
|
||||
echoIO :: Sem '[Embed IO] ()
|
||||
echoIO = runTeletypeIO echo
|
||||
|
||||
-- echo forever
|
||||
|
@ -36,7 +36,7 @@ prog
|
||||
:: Sem '[ State Bool
|
||||
, Error Bool
|
||||
, Resource
|
||||
, Lift IO
|
||||
, Embed IO
|
||||
] Bool
|
||||
prog = catch @Bool (throw True) (pure . not)
|
||||
|
||||
|
@ -16,10 +16,10 @@ data Teletype m a where
|
||||
|
||||
makeSem ''Teletype
|
||||
|
||||
runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a
|
||||
runTeletypeIO :: Member (Embed IO) r => Sem (Teletype ': r) a -> Sem r a
|
||||
runTeletypeIO = interpret $ \case
|
||||
ReadTTY -> sendM getLine
|
||||
WriteTTY msg -> sendM $ putStrLn msg
|
||||
ReadTTY -> embed getLine
|
||||
WriteTTY msg -> embed $ putStrLn msg
|
||||
|
||||
data CustomException = ThisException | ThatException deriving Show
|
||||
|
||||
|
@ -6,8 +6,8 @@ import Polysemy
|
||||
import Test.Hspec
|
||||
import Test.ShouldNotTypecheck
|
||||
|
||||
wrongLift :: Member (Lift IO) r => Sem r ()
|
||||
wrongLift = sendM putStrLn
|
||||
wrongEmbed :: Member (Embed IO) r => Sem r ()
|
||||
wrongEmbed = embed putStrLn
|
||||
|
||||
wrongReturn :: Sem (e ': r) () -> Sem r ()
|
||||
wrongReturn = reinterpret undefined
|
||||
@ -17,8 +17,8 @@ wrongReturn = reinterpret undefined
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Legitimate type errors" $ do
|
||||
it "should be caused by `sendM`ing an unsaturated function" $
|
||||
shouldNotTypecheck wrongLift
|
||||
it "should be caused by `embed`ing an unsaturated function" $
|
||||
shouldNotTypecheck wrongEmbed
|
||||
|
||||
it "should be caused by giving a bad type to reinterpret" $
|
||||
shouldNotTypecheck wrongReturn
|
||||
|
@ -46,8 +46,8 @@ errState = do
|
||||
err
|
||||
|
||||
|
||||
lifted :: Monad m => Member (Lift m) r => Sem r ()
|
||||
lifted = sendM $ pure ()
|
||||
lifted :: Monad m => Member (Embed m) r => Sem r ()
|
||||
lifted = embed $ pure ()
|
||||
|
||||
|
||||
newtype MyString = MyString String
|
||||
@ -136,7 +136,7 @@ spec = do
|
||||
output $ replicate 2 5
|
||||
|
||||
|
||||
describe "Lift effect" $ do
|
||||
describe "Embed effect" $ do
|
||||
it "should interpret against IO" $ do
|
||||
res <- runM lifted
|
||||
res `shouldBe` ()
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: e22afd49cd8b82cdc69be962d872539c65eedc43a2978aa7a0652b40dd7db105
|
||||
-- hash: 7e0e9242c36e377756ae6ef007d19a16cdaf3f244855b0bfc97e267f4df143ea
|
||||
|
||||
name: polysemy
|
||||
version: 0.7.0.0
|
||||
@ -41,6 +41,8 @@ library
|
||||
exposed-modules:
|
||||
Polysemy
|
||||
Polysemy.Async
|
||||
Polysemy.Embed
|
||||
Polysemy.Embed.Type
|
||||
Polysemy.Error
|
||||
Polysemy.Fixpoint
|
||||
Polysemy.Input
|
||||
@ -51,7 +53,6 @@ library
|
||||
Polysemy.Internal.Fixpoint
|
||||
Polysemy.Internal.Forklift
|
||||
Polysemy.Internal.Kind
|
||||
Polysemy.Internal.Lift
|
||||
Polysemy.Internal.NonDet
|
||||
Polysemy.Internal.Tactics
|
||||
Polysemy.Internal.TH.Common
|
||||
|
@ -10,8 +10,8 @@ module Polysemy
|
||||
, runM
|
||||
|
||||
-- * Interoperating With Other Monads
|
||||
, Lift (..)
|
||||
, sendM
|
||||
, Embed (..)
|
||||
, embed
|
||||
|
||||
-- * Lifting
|
||||
, raise
|
||||
|
@ -41,7 +41,7 @@ makeSem ''Async
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
runAsync
|
||||
:: LastMember (Lift IO) r
|
||||
:: LastMember (Embed IO) r
|
||||
=> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
runAsync m = withLowerToIO $ \lower _ -> lower $
|
||||
@ -50,10 +50,10 @@ runAsync m = withLowerToIO $ \lower _ -> lower $
|
||||
Async a -> do
|
||||
ma <- runT a
|
||||
ins <- getInspectorT
|
||||
fa <- sendM $ A.async $ lower $ runAsync ma
|
||||
fa <- embed $ A.async $ lower $ runAsync ma
|
||||
pureT $ fmap (inspect ins) fa
|
||||
|
||||
Await a -> pureT =<< sendM (A.wait a)
|
||||
Await a -> pureT =<< embed (A.wait a)
|
||||
) m
|
||||
{-# INLINE runAsync #-}
|
||||
|
||||
@ -64,7 +64,7 @@ runAsync m = withLowerToIO $ \lower _ -> lower $
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
runAsyncInIO
|
||||
:: Member (Lift IO) r
|
||||
:: Member (Embed IO) r
|
||||
=> (forall x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
|
||||
-- some combination of 'runM' and other interpreters composed via '.@'.
|
||||
@ -75,10 +75,10 @@ runAsyncInIO lower m = interpretH
|
||||
Async a -> do
|
||||
ma <- runT a
|
||||
ins <- getInspectorT
|
||||
fa <- sendM $ A.async $ lower $ runAsyncInIO lower ma
|
||||
fa <- embed $ A.async $ lower $ runAsyncInIO lower ma
|
||||
pureT $ fmap (inspect ins) fa
|
||||
|
||||
Await a -> pureT =<< sendM (A.wait a)
|
||||
Await a -> pureT =<< embed (A.wait a)
|
||||
) m
|
||||
{-# INLINE runAsyncInIO #-}
|
||||
|
||||
|
29
src/Polysemy/Embed.hs
Normal file
29
src/Polysemy/Embed.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Polysemy.Embed
|
||||
( -- * Effect
|
||||
Embed (..)
|
||||
|
||||
-- * Actions
|
||||
, embed
|
||||
|
||||
-- * Interpretations
|
||||
, runEmbedded
|
||||
) where
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Embed.Type (Embed (..))
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a natural transform from @m1@ to @m2@
|
||||
-- run a @Embed m1@ effect by transforming it into a @Embed m2@ effect.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
runEmbedded
|
||||
:: forall m1 m2 r a
|
||||
. Member (Embed m2) r
|
||||
=> (forall x. m1 x -> m2 x)
|
||||
-> Sem (Embed m1 ': r) a
|
||||
-> Sem r a
|
||||
runEmbedded f = interpret $ embed . f . unEmbed
|
||||
{-# INLINE runEmbedded #-}
|
@ -2,7 +2,10 @@
|
||||
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
module Polysemy.Internal.Lift where
|
||||
module Polysemy.Embed.Type
|
||||
( -- * Effect
|
||||
Embed (..)
|
||||
) where
|
||||
|
||||
import Data.Kind
|
||||
|
||||
@ -10,23 +13,22 @@ import Data.Kind
|
||||
------------------------------------------------------------------------------
|
||||
-- | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Sem'
|
||||
-- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Sem' via
|
||||
-- 'Polysemy.sendM'.
|
||||
-- 'Polysemy.embed'.
|
||||
--
|
||||
-- For example, you can use this effect to lift 'IO' actions directly into
|
||||
-- 'Polysemy.Sem':
|
||||
--
|
||||
-- @
|
||||
-- 'Polysemy.sendM' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Lift' IO) r => 'Polysemy.Sem' r ()
|
||||
-- 'Polysemy.embed' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Embed' IO) r => 'Polysemy.Sem' r ()
|
||||
-- @
|
||||
--
|
||||
-- That being said, you lose out on a significant amount of the benefits of
|
||||
-- 'Polysemy.Sem' by using 'Polysemy.sendM' directly in application code; doing
|
||||
-- 'Polysemy.Sem' by using 'Polysemy.embed' directly in application code; doing
|
||||
-- so will tie your application code directly to the underlying monad, and
|
||||
-- prevent you from interpreting it differently. For best results, only use
|
||||
-- 'Lift' in your effect interpreters.
|
||||
-- 'Embed' in your effect interpreters.
|
||||
--
|
||||
-- Consider using 'Polysemy.Trace.trace' and 'Polysemy.Trace.runTraceIO' as
|
||||
-- a substitute for using 'putStrLn' directly.
|
||||
newtype Lift m (z :: Type -> Type) a where
|
||||
Lift :: { unLift :: m a } -> Lift m z a
|
||||
|
||||
newtype Embed m (z :: Type -> Type) a where
|
||||
Embed :: { unEmbed :: m a } -> Embed m z a
|
@ -51,18 +51,18 @@ fromEither (Right a) = pure a
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A combinator doing 'sendM' and 'fromEither' at the same time. Useful for
|
||||
-- | A combinator doing 'embed' and 'fromEither' at the same time. Useful for
|
||||
-- interoperating with 'IO'.
|
||||
--
|
||||
-- @since 0.5.1.0
|
||||
fromEitherM
|
||||
:: forall e m r a
|
||||
. ( Member (Error e) r
|
||||
, Member (Lift m) r
|
||||
, Member (Embed m) r
|
||||
)
|
||||
=> m (Either e a)
|
||||
-> Sem r a
|
||||
fromEitherM = fromEither <=< sendM
|
||||
fromEitherM = fromEither <=< embed
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -135,7 +135,7 @@ instance (Typeable e) => X.Exception (WrappedExc e)
|
||||
-- significantly faster than 'runError', at the cost of being less flexible.
|
||||
runErrorInIO
|
||||
:: ( Typeable e
|
||||
, Member (Lift IO) r
|
||||
, Member (Embed IO) r
|
||||
)
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is
|
||||
@ -144,7 +144,7 @@ runErrorInIO
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
runErrorInIO lower
|
||||
= sendM
|
||||
= embed
|
||||
. fmap (first unwrapExc)
|
||||
. X.try
|
||||
. (lower .@ runErrorAsExc)
|
||||
@ -154,19 +154,19 @@ runErrorInIO lower
|
||||
-- TODO(sandy): Can we use the new withLowerToIO machinery for this?
|
||||
runErrorAsExc
|
||||
:: forall e r a. ( Typeable e
|
||||
, Member (Lift IO) r
|
||||
, Member (Embed IO) r
|
||||
)
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r a
|
||||
runErrorAsExc lower = interpretH $ \case
|
||||
Throw e -> sendM $ X.throwIO $ WrappedExc e
|
||||
Throw e -> embed $ X.throwIO $ WrappedExc e
|
||||
Catch try handle -> do
|
||||
is <- getInitialStateT
|
||||
t <- runT try
|
||||
h <- bindT handle
|
||||
let runIt = lower . runErrorAsExc lower
|
||||
sendM $ X.catch (runIt t) $ \(se :: WrappedExc e) ->
|
||||
embed $ X.catch (runIt t) $ \(se :: WrappedExc e) ->
|
||||
runIt $ h $ unwrapExc se <$ is
|
||||
{-# INLINE runErrorAsExc #-}
|
||||
|
||||
|
@ -29,7 +29,7 @@ runFixpoint lower = interpretH $ \case
|
||||
-- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.
|
||||
runFixpointM
|
||||
:: ( MonadFix m
|
||||
, Member (Lift m) r
|
||||
, Member (Embed m) r
|
||||
)
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-> Sem (Fixpoint ': r) a
|
||||
@ -37,5 +37,5 @@ runFixpointM
|
||||
runFixpointM lower = interpretH $ \case
|
||||
Fixpoint mf -> do
|
||||
c <- bindT mf
|
||||
sendM $ mfix $ lower . runFixpointM lower . c
|
||||
embed $ mfix $ lower . runFixpointM lower . c
|
||||
|
||||
|
@ -3,11 +3,12 @@
|
||||
module Polysemy.IO
|
||||
( -- * Interpretations
|
||||
runIO
|
||||
, runEmbedded
|
||||
, runEmbeddedInIO
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Polysemy
|
||||
import Polysemy.Embed
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
@ -37,37 +38,37 @@ import Polysemy.Internal.Union
|
||||
runIO
|
||||
:: forall m r a
|
||||
. ( MonadIO m
|
||||
, Member (Lift m) r
|
||||
, Member (Embed m) r
|
||||
)
|
||||
=> Sem (Lift IO ': r) a
|
||||
=> Sem (Embed IO ': r) a
|
||||
-> Sem r a
|
||||
runIO = interpret $ sendM . liftIO @m . unLift
|
||||
runIO = runEmbedded $ liftIO @m
|
||||
{-# INLINE runIO #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given some @'MonadIO' m@, interpret all @'Lift' m@ actions in that monad
|
||||
-- | Given some @'MonadIO' m@, interpret all @'Embed' m@ actions in that monad
|
||||
-- at once. This is useful for interpreting effects like databases, which use
|
||||
-- their own monad for describing actions.
|
||||
--
|
||||
-- This function creates a thread, and so should be compiled with @-threaded@.
|
||||
--
|
||||
-- @since 0.6.0.0
|
||||
runEmbedded
|
||||
-- TODO(sandy): @since
|
||||
runEmbeddedInIO
|
||||
:: ( MonadIO m
|
||||
, LastMember (Lift IO) r
|
||||
, LastMember (Embed IO) r
|
||||
)
|
||||
=> (forall x. m x -> IO x) -- ^ The means of running this monad.
|
||||
-> Sem (Lift m ': r) a
|
||||
-> Sem (Embed m ': r) a
|
||||
-> Sem r a
|
||||
runEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->
|
||||
runEmbeddedInIO run_m (Sem m) = withLowerToIO $ \lower _ ->
|
||||
run_m $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> liftIO
|
||||
. lower
|
||||
. liftSem
|
||||
$ hoist (runEmbedded run_m) x
|
||||
$ hoist (runEmbeddedInIO run_m) x
|
||||
|
||||
Right (Weaving (Lift wd) s _ y _) ->
|
||||
Right (Weaving (Embed wd) s _ y _) ->
|
||||
fmap y $ fmap (<$ s) wd
|
||||
|
||||
|
@ -11,14 +11,14 @@ module Polysemy.Internal
|
||||
, Member
|
||||
, Members
|
||||
, send
|
||||
, sendM
|
||||
, embed
|
||||
, run
|
||||
, runM
|
||||
, raise
|
||||
, raiseUnder
|
||||
, raiseUnder2
|
||||
, raiseUnder3
|
||||
, Lift (..)
|
||||
, Embed (..)
|
||||
, usingSem
|
||||
, liftSem
|
||||
, hoistSem
|
||||
@ -34,7 +34,7 @@ import Control.Monad.IO.Class
|
||||
import Data.Functor.Identity
|
||||
import Data.Kind
|
||||
import Polysemy.Internal.Fixpoint
|
||||
import Polysemy.Internal.Lift
|
||||
import Polysemy.Embed.Type
|
||||
import Polysemy.Internal.NonDet
|
||||
import Polysemy.Internal.PluginLookup
|
||||
import Polysemy.Internal.Union
|
||||
@ -57,8 +57,8 @@ import Polysemy.Internal.Union
|
||||
-- 'Polysemy.Error.runError' to 'Polysemy.Error.runErrorInIO'.
|
||||
--
|
||||
-- The effect stack @r@ can contain arbitrary other monads inside of it. These
|
||||
-- monads are lifted into effects via the 'Lift' effect. Monadic values can be
|
||||
-- lifted into a 'Sem' via 'sendM'.
|
||||
-- monads are lifted into effects via the 'Embed' effect. Monadic values can be
|
||||
-- lifted into a 'Sem' via 'embed'.
|
||||
--
|
||||
-- A 'Sem' can be interpreted as a pure value (via 'run') or as any
|
||||
-- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some
|
||||
@ -73,7 +73,7 @@ import Polysemy.Internal.Union
|
||||
-- monomorphic representation of the @r@ parameter.
|
||||
--
|
||||
-- After all of your effects are handled, you'll be left with either
|
||||
-- a @'Sem' '[] a@ or a @'Sem' '[ 'Lift' m ] a@ value, which can be
|
||||
-- a @'Sem' '[] a@ or a @'Sem' '[ 'Embed' m ] a@ value, which can be
|
||||
-- consumed respectively by 'run' and 'runM'.
|
||||
--
|
||||
-- ==== Examples
|
||||
@ -231,8 +231,8 @@ instance (Member NonDet r) => MonadFail (Sem r) where
|
||||
-- | This instance will only lift 'IO' actions. If you want to lift into some
|
||||
-- other 'MonadIO' type, use this instance, and handle it via the
|
||||
-- 'Polysemy.IO.runIO' interpretation.
|
||||
instance (Member (Lift IO) r) => MonadIO (Sem r) where
|
||||
liftIO = sendM
|
||||
instance (Member (Embed IO) r) => MonadIO (Sem r) where
|
||||
liftIO = embed
|
||||
{-# INLINE liftIO #-}
|
||||
|
||||
instance Member Fixpoint r => MonadFix (Sem r) where
|
||||
@ -300,7 +300,7 @@ raiseUnder3 = hoistSem $ hoist raiseUnder3 . weakenUnder3
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lift an effect into a 'Sem'. This is used primarily via
|
||||
-- | Embed an effect into a 'Sem'. This is used primarily via
|
||||
-- 'Polysemy.makeSem' to implement smart constructors.
|
||||
send :: Member e r => e (Sem r) a -> Sem r a
|
||||
send = liftSem . inj
|
||||
@ -308,10 +308,12 @@ send = liftSem . inj
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lift a monadic action @m@ into 'Sem'.
|
||||
sendM :: Member (Lift m) r => m a -> Sem r a
|
||||
sendM = send . Lift
|
||||
{-# INLINE sendM #-}
|
||||
-- | Embed a monadic action @m@ in 'Sem'.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
embed :: Member (Embed m) r => m a -> Sem r a
|
||||
embed = send . Embed
|
||||
{-# INLINE embed #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -324,11 +326,11 @@ run (Sem m) = runIdentity $ m absurdU
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lower a 'Sem' containing only a single lifted 'Monad' into that
|
||||
-- monad.
|
||||
runM :: Monad m => Sem '[Lift m] a -> m a
|
||||
runM :: Monad m => Sem '[Embed m] a -> m a
|
||||
runM (Sem m) = m $ \z ->
|
||||
case extract z of
|
||||
Weaving e s _ f _ -> do
|
||||
a <- unLift e
|
||||
a <- unEmbed e
|
||||
pure $ f $ a <$ s
|
||||
{-# INLINE runM #-}
|
||||
|
||||
|
@ -19,7 +19,7 @@ import Polysemy.Internal.Union
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
data Forklift r = forall a. Forklift
|
||||
{ responseMVar :: MVar (Sem '[Lift IO] a)
|
||||
{ responseMVar :: MVar (Sem '[Embed IO] a)
|
||||
, request :: Union r (Sem r) a
|
||||
}
|
||||
|
||||
@ -30,13 +30,13 @@ data Forklift r = forall a. Forklift
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
runViaForklift
|
||||
:: LastMember (Lift IO) r
|
||||
:: LastMember (Embed IO) r
|
||||
=> InChan (Forklift r)
|
||||
-> Sem r a
|
||||
-> Sem '[Lift IO] a
|
||||
-> Sem '[Embed IO] a
|
||||
runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do
|
||||
case decompLast u of
|
||||
Left x -> usingSem k $ join $ sendM $ do
|
||||
Left x -> usingSem k $ join $ embed $ do
|
||||
mvar <- newEmptyMVar
|
||||
writeChan chan $ Forklift mvar x
|
||||
takeMVar mvar
|
||||
@ -53,29 +53,29 @@ runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
withLowerToIO
|
||||
:: LastMember (Lift IO) r
|
||||
:: LastMember (Embed IO) r
|
||||
=> ((forall x. Sem r x -> IO x) -> IO () -> IO a)
|
||||
-- ^ A lambda that takes the lowering function, and a finalizing 'IO'
|
||||
-- action to mark a the forked thread as being complete. The finalizing
|
||||
-- action need not be called.
|
||||
-> Sem r a
|
||||
withLowerToIO action = do
|
||||
(inchan, outchan) <- sendM newChan
|
||||
signal <- sendM newEmptyMVar
|
||||
(inchan, outchan) <- embed newChan
|
||||
signal <- embed newEmptyMVar
|
||||
|
||||
res <- sendM $ A.async $ do
|
||||
res <- embed $ A.async $ do
|
||||
a <- action (runM . runViaForklift inchan)
|
||||
(putMVar signal ())
|
||||
putMVar signal ()
|
||||
pure a
|
||||
|
||||
let me = do
|
||||
raced <- sendM $ A.race (takeMVar signal) $ readChan outchan
|
||||
raced <- embed $ A.race (takeMVar signal) $ readChan outchan
|
||||
case raced of
|
||||
Left () -> sendM $ A.wait res
|
||||
Left () -> embed $ A.wait res
|
||||
Right (Forklift mvar req) -> do
|
||||
resp <- liftSem req
|
||||
sendM $ putMVar mvar $ pure resp
|
||||
embed $ putMVar mvar $ pure resp
|
||||
me_b
|
||||
{-# INLINE me #-}
|
||||
|
||||
|
@ -81,7 +81,7 @@ onException act end = bracketOnError (pure ()) (const end) (const act)
|
||||
-- @since 0.4.0.0
|
||||
runResourceInIO
|
||||
:: ∀ r a
|
||||
. Member (Lift IO) r
|
||||
. Member (Embed IO) r
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
|
||||
-- some combination of 'runM' and other interpreters composed via '.@'.
|
||||
@ -96,7 +96,7 @@ runResourceInIO finish = interpretH $ \case
|
||||
let run_it :: Sem (Resource ': r) x -> IO x
|
||||
run_it = finish .@ runResourceInIO
|
||||
|
||||
sendM $ X.bracket (run_it a) (run_it . d) (run_it . u)
|
||||
embed $ X.bracket (run_it a) (run_it . d) (run_it . u)
|
||||
|
||||
BracketOnError alloc dealloc use -> do
|
||||
a <- runT alloc
|
||||
@ -106,7 +106,7 @@ runResourceInIO finish = interpretH $ \case
|
||||
let run_it :: Sem (Resource ': r) x -> IO x
|
||||
run_it = finish .@ runResourceInIO
|
||||
|
||||
sendM $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
|
||||
embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
|
||||
{-# INLINE runResourceInIO #-}
|
||||
|
||||
|
||||
@ -168,7 +168,7 @@ runResource = interpretH $ \case
|
||||
-- @since 0.5.0.0
|
||||
runResourceBase
|
||||
:: forall r a
|
||||
. LastMember (Lift IO) r
|
||||
. LastMember (Embed IO) r
|
||||
=> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
runResourceBase = interpretH $ \case
|
||||
|
@ -79,13 +79,13 @@ runLazyState = lazilyStateful $ \case
|
||||
-- @since 0.1.2.0
|
||||
runStateInIORef
|
||||
:: forall s r a
|
||||
. Member (Lift IO) r
|
||||
. Member (Embed IO) r
|
||||
=> IORef s
|
||||
-> Sem (State s ': r) a
|
||||
-> Sem r a
|
||||
runStateInIORef ref = interpret $ \case
|
||||
Get -> sendM $ readIORef ref
|
||||
Put s -> sendM $ writeIORef ref s
|
||||
Get -> embed $ readIORef ref
|
||||
Put s -> embed $ writeIORef ref s
|
||||
{-# INLINE runStateInIORef #-}
|
||||
|
||||
|
||||
|
@ -31,15 +31,15 @@ makeSem ''Trace
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Trace' effect by printing the messages to stdout.
|
||||
runTraceIO :: Member (Lift IO) r => Sem (Trace ': r) a -> Sem r a
|
||||
runTraceIO :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a
|
||||
runTraceIO = interpret $ \case
|
||||
Trace m -> sendM $ putStrLn m
|
||||
Trace m -> embed $ putStrLn m
|
||||
{-# INLINE runTraceIO #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Trace' effect by ignoring all of its messages.
|
||||
runIgnoringTrace :: Member (Lift IO) r => Sem (Trace ': r) a -> Sem r a
|
||||
runIgnoringTrace :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a
|
||||
runIgnoringTrace = interpret $ \case
|
||||
Trace _ -> pure ()
|
||||
{-# INLINE runIgnoringTrace #-}
|
||||
|
@ -27,14 +27,14 @@ spec = describe "async" $ do
|
||||
message 1 v
|
||||
put $ reverse v
|
||||
|
||||
sendM $ threadDelay 1e5
|
||||
embed $ threadDelay 1e5
|
||||
get >>= message 1
|
||||
|
||||
sendM $ threadDelay 1e5
|
||||
embed $ threadDelay 1e5
|
||||
get @String
|
||||
|
||||
void $ async $ do
|
||||
sendM $ threadDelay 5e4
|
||||
embed $ threadDelay 5e4
|
||||
get >>= message 2
|
||||
put "pong"
|
||||
|
||||
|
@ -19,7 +19,7 @@ runTest = run
|
||||
. runError @()
|
||||
|
||||
runTest2
|
||||
:: Sem '[Error (), Resource, State [Char], Trace, Lift IO] a
|
||||
:: Sem '[Error (), Resource, State [Char], Trace, Embed IO] a
|
||||
-> IO ([String], ([Char], Either () a))
|
||||
runTest2 = runM
|
||||
. runTraceAsList
|
||||
|
@ -25,7 +25,7 @@ spec = parallel $ describe "Inspector" $ do
|
||||
void . (runM .@ runCallback ref)
|
||||
. runState False
|
||||
$ do
|
||||
sendM $ pretendPrint ref "hello world"
|
||||
embed $ pretendPrint ref "hello world"
|
||||
callback $ show <$> get @Bool
|
||||
modify not
|
||||
callback $ show <$> get @Bool
|
||||
@ -47,7 +47,7 @@ spec = parallel $ describe "Inspector" $ do
|
||||
|
||||
|
||||
runCallback
|
||||
:: Member (Lift IO) r
|
||||
:: Member (Embed IO) r
|
||||
=> IORef [String]
|
||||
-> (forall x. Sem r x -> IO x)
|
||||
-> Sem (Callback ': r) a
|
||||
@ -56,7 +56,7 @@ runCallback ref lower = interpretH $ \case
|
||||
Callback cb -> do
|
||||
cb' <- runT cb
|
||||
ins <- getInspectorT
|
||||
sendM $ doCB ref $ do
|
||||
embed $ doCB ref $ do
|
||||
v <- lower .@ runCallback ref $ cb'
|
||||
pure $ maybe ":(" id $ inspect ins v
|
||||
getInitialStateT
|
||||
|
@ -89,9 +89,9 @@ tooFewArgumentsReinterpret = ()
|
||||
-- in runM foo'''
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Unhandled effect 'Lift IO'
|
||||
-- ... Unhandled effect 'Embed IO'
|
||||
-- ...
|
||||
-- ... Expected type: Sem '[Lift m] (Bool, ())
|
||||
-- ... Expected type: Sem '[Embed m] (Bool, ())
|
||||
-- ... Actual type: Sem '[] (Bool, ())
|
||||
-- ...
|
||||
runningTooManyEffects = ()
|
||||
@ -142,7 +142,7 @@ missingFmap'PLUGIN = ()
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- foo :: Sem '[State Int, Lift IO] ()
|
||||
-- foo :: Sem '[State Int, Embed IO] ()
|
||||
-- foo = output ()
|
||||
-- :}
|
||||
-- ...
|
||||
|
Loading…
Reference in New Issue
Block a user