{-# LANGUAGE TemplateHaskell #-}
module Polysemy.Resource
(
Resource (..)
, bracket
, bracketOnError
, finally
, onException
, runResource
, runResourceInIO
, runResourceBase
) where
import qualified Control.Exception as X
import Polysemy
data Resource m a where
Bracket
:: m a
-> (a -> m c)
-> (a -> m b)
-> Resource m b
BracketOnError
:: m a
-> (a -> m c)
-> (a -> m b)
-> Resource m b
makeSem ''Resource
finally
:: Member Resource r
=> Sem r a
-> Sem r b
-> Sem r a
finally act end = bracket (pure ()) (pure end) (const act)
onException
:: Member Resource r
=> Sem r a
-> Sem r b
-> Sem r a
onException act end = bracketOnError (pure ()) (const end) (const act)
runResourceInIO
:: ∀ r a
. Member (Lift IO) r
=> (∀ x. Sem r x -> IO x)
-> Sem (Resource ': r) a
-> Sem r a
runResourceInIO finish = interpretH $ \case
Bracket alloc dealloc use -> do
a <- runT alloc
d <- bindT dealloc
u <- bindT use
let run_it :: Sem (Resource ': r) x -> IO x
run_it = finish .@ runResourceInIO_b
sendM $ X.bracket (run_it a) (run_it . d) (run_it . u)
BracketOnError alloc dealloc use -> do
a <- runT alloc
d <- bindT dealloc
u <- bindT use
let run_it :: Sem (Resource ': r) x -> IO x
run_it = finish .@ runResourceInIO_b
sendM $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
runResource
:: ∀ r a
. Sem (Resource ': r) a
-> Sem r a
runResource = interpretH $ \case
Bracket alloc dealloc use -> do
a <- runT alloc
d <- bindT dealloc
u <- bindT use
let run_it = raise . runResource_b
resource <- run_it a
result <- run_it $ u resource
_ <- run_it $ d resource
pure result
BracketOnError alloc dealloc use -> do
a <- runT alloc
d <- bindT dealloc
u <- bindT use
let run_it = raise . runResource_b
resource <- run_it a
result <- run_it $ u resource
ins <- getInspectorT
case inspect ins result of
Just _ -> pure result
Nothing -> do
_ <- run_it $ d resource
pure result
{-# INLINE runResource #-}
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
-> Sem r a
runResource_b = runResource
{-# NOINLINE runResource_b #-}
runResourceInIO_b
:: ∀ r a
. Member (Lift IO) r
=> (∀ x. Sem r x -> IO x)
-> Sem (Resource ': r) a
-> Sem r a
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 #-}