{-# LANGUAGE TemplateHaskell #-}
module Polysemy.Resource
(
Resource (..)
, bracket
, bracketOnError
, finally
, onException
, runResource
, lowerResource
, resourceToIO
) 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)
lowerResource
:: ∀ r a
. Member (Embed IO) r
=> (∀ x. Sem r x -> IO x)
-> Sem (Resource ': r) a
-> Sem r a
lowerResource 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 .@ lowerResource
embed $ 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 .@ lowerResource
embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
{-# INLINE lowerResource #-}
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
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
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 #-}
resourceToIO
:: forall r a
. Member (Embed IO) r
=> Sem (Resource ': r) a
-> Sem r a
resourceToIO = 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 . resourceToIO
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 . resourceToIO
X.bracketOnError
(done ma)
(\x -> done (mb x) >> finish)
(done . mc)
{-# INLINE resourceToIO #-}