{-# LANGUAGE TemplateHaskell #-}
module Polysemy.Resource
(
Resource (..)
, bracket
, bracketOnError
, finally
, onException
, runResource
, runResourceInIO
) 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 #-}
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 #-}