mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
runResource via forklift (#130)
This PR adds `runResourceBase` (which is a crap name, but naming things is hard), which interprets `Resource` without the ugly `Sem r ~> IO` parameter. It's a nice solution to #84!
This commit is contained in:
parent
8f3a4bcf19
commit
33a6d95dab
@ -86,6 +86,9 @@
|
||||
|
||||
- Lots of hard work on the package and CI infrastructure to make it green on
|
||||
GHC 8.4.4 (thanks to @jkachmar)
|
||||
- runResourceBase
|
||||
- runTraceAsList
|
||||
- New effect: Async
|
||||
- Changed the order of the types for `runMonadicInput` to be more helpful
|
||||
(thanks to @tempname11)
|
||||
|
||||
|
@ -13,10 +13,12 @@ module Polysemy.Resource
|
||||
-- * Interpretations
|
||||
, runResource
|
||||
, runResourceInIO
|
||||
, runResourceBase
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import Polysemy
|
||||
import Polysemy.Internal.Forklift
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -147,6 +149,55 @@ runResource = interpretH $ \case
|
||||
{-# INLINE runResource #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A more flexible --- though less safe --- version of 'runResourceInIO'.
|
||||
--
|
||||
-- This function is capable of running 'Resource' effects anywhere within an
|
||||
-- effect stack, without relying on an explicit function to lower it into 'IO'.
|
||||
-- Notably, this means that 'Polysemy.State.State' effects will be consistent
|
||||
-- in the presence of 'Resource'.
|
||||
--
|
||||
-- 'runResourceBase' is safe whenever you're concerned about exceptions thrown
|
||||
-- by effects _already handled_ in your effect stack, or in 'IO' code run
|
||||
-- directly inside of 'bracket'. It is not safe against exceptions thrown
|
||||
-- explicitly at the main thread. If this is not safe enough for your use-case,
|
||||
-- use 'runResourceInIO' instead.
|
||||
--
|
||||
-- TODO(sandy): @since version
|
||||
runResourceBase
|
||||
:: forall r a
|
||||
. LastMember (Lift IO) r
|
||||
=> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
runResourceBase = interpretH $ \case
|
||||
Bracket a b c -> do
|
||||
ma <- runT a
|
||||
mb <- bindT b
|
||||
mc <- bindT c
|
||||
|
||||
withLowerToIO $ \lower finish -> do
|
||||
let done :: Sem (Resource ': r) x -> IO x
|
||||
done = lower . raise . runResourceBase_b
|
||||
X.bracket
|
||||
(done ma)
|
||||
(\x -> done (mb x) >> finish)
|
||||
(done . mc)
|
||||
|
||||
BracketOnError a b c -> do
|
||||
ma <- runT a
|
||||
mb <- bindT b
|
||||
mc <- bindT c
|
||||
|
||||
withLowerToIO $ \lower finish -> do
|
||||
let done :: Sem (Resource ': r) x -> IO x
|
||||
done = lower . raise . runResourceBase_b
|
||||
X.bracketOnError
|
||||
(done ma)
|
||||
(\x -> done (mb x) >> finish)
|
||||
(done . mc)
|
||||
{-# INLINE runResourceBase #-}
|
||||
|
||||
|
||||
runResource_b
|
||||
:: ∀ r a
|
||||
. Sem (Resource ': r) a
|
||||
@ -163,3 +214,11 @@ runResourceInIO_b
|
||||
runResourceInIO_b = runResourceInIO
|
||||
{-# NOINLINE runResourceInIO_b #-}
|
||||
|
||||
runResourceBase_b
|
||||
:: forall r a
|
||||
. LastMember (Lift IO) r
|
||||
=> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
runResourceBase_b = runResourceBase
|
||||
{-# NOINLINE runResourceBase_b #-}
|
||||
|
||||
|
@ -10,15 +10,23 @@ import Test.Hspec
|
||||
|
||||
|
||||
runTest
|
||||
:: Sem '[Error (), Resource, State [Char], Trace, Output String] a
|
||||
:: Sem '[Error (), Resource, State [Char], Trace] a
|
||||
-> ([String], ([Char], Either () a))
|
||||
runTest = run
|
||||
. runFoldMapOutput @String (:[])
|
||||
. runTraceAsOutput
|
||||
. runTraceAsList
|
||||
. runState ""
|
||||
. runResource
|
||||
. runError @()
|
||||
|
||||
runTest2
|
||||
:: Sem '[Error (), Resource, State [Char], Trace, Lift IO] a
|
||||
-> IO ([String], ([Char], Either () a))
|
||||
runTest2 = runM
|
||||
. runTraceAsList
|
||||
. runState ""
|
||||
. runResourceBase
|
||||
. runError @()
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
@ -80,3 +88,56 @@ spec = parallel $ do
|
||||
s `shouldBe` "don't get here"
|
||||
e `shouldBe` Right ()
|
||||
|
||||
|
||||
describe "io dispatched bracket" $ do
|
||||
it "persist state and call the finalizer" $ do
|
||||
(ts, (s, e)) <- runTest2 $ do
|
||||
bracket
|
||||
(put "allocated" >> pure ())
|
||||
(\() -> do
|
||||
get >>= trace
|
||||
put "finalized"
|
||||
)
|
||||
(\() -> do
|
||||
get >>= trace
|
||||
put "starting block"
|
||||
_ <- throw ()
|
||||
put "don't get here"
|
||||
)
|
||||
ts `shouldContain` ["allocated"]
|
||||
ts `shouldContain` ["starting block"]
|
||||
s `shouldBe` "finalized"
|
||||
e `shouldBe` Left ()
|
||||
|
||||
it "should not lock when done recursively" $ do
|
||||
(ts, (s, e)) <- runTest2 $ do
|
||||
bracket
|
||||
(put "hello 1")
|
||||
(\() -> do
|
||||
get >>= trace
|
||||
put "finished"
|
||||
)
|
||||
(\() -> do
|
||||
get >>= trace
|
||||
bracket (put "hello 2")
|
||||
(const $ do
|
||||
get >>= trace
|
||||
put "goodbye 2"
|
||||
)
|
||||
(const $ do
|
||||
get >>= trace
|
||||
put "RUNNING"
|
||||
throw ()
|
||||
)
|
||||
-- This doesn't run due to the thrown error above
|
||||
get >>= trace
|
||||
put "goodbye 1"
|
||||
)
|
||||
ts `shouldContain` [ "hello 1"
|
||||
, "hello 2"
|
||||
, "RUNNING"
|
||||
, "goodbye 2"
|
||||
]
|
||||
s `shouldBe` "finished"
|
||||
e `shouldBe` Left ()
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user