Region.hs

module Resource.Region
  ( run
  , exec
  , eval

  , local
  , local_

  , register_
  , attach
  , attachAsync

  , logDebug

  , ReleaseKey
  , ResourceT.release
  ) where

import RIO hiding (local, logDebug)

import Control.Monad.Trans.Resource (MonadResource, ResourceT, ReleaseKey)
import Control.Monad.Trans.Resource qualified as ResourceT
import GHC.Stack (withFrozenCallStack)
import RIO qualified

run :: MonadResource m => ResourceT m a -> m (ReleaseKey, a)
run action = do
  regionResource <- ResourceT.createInternalState
  regionKey <- ResourceT.register $ ResourceT.closeInternalState regionResource
  resource <- ResourceT.runInternalState action regionResource
  pure (regionKey, resource)

exec :: MonadResource m => ResourceT m a -> m ReleaseKey
exec = fmap fst . run

eval :: MonadResource m => ResourceT m a -> m a
eval = fmap snd . run

local :: MonadResource m => m (ReleaseKey, a) -> ResourceT m a
local action = do
  (key, resource) <- lift action
  ResourceT.register $
    ResourceT.release key
  pure resource

local_ :: MonadResource m => m ReleaseKey -> ResourceT m ()
local_ action = do
  key <- lift action
  void . ResourceT.register $
    ResourceT.release key

register_ :: MonadUnliftIO m => IO () -> ResourceT m ()
register_ = void . ResourceT.register

attach :: MonadUnliftIO m => ReleaseKey -> ResourceT m ()
attach = register_ . ResourceT.release

attachAsync :: MonadUnliftIO m => Async a -> ResourceT m ()
attachAsync = register_ . cancel

logDebug
  :: ( MonadUnliftIO m
     , MonadReader env m, HasLogFunc env
     , HasCallStack
     )
  => Utf8Builder
  -> Utf8Builder
  -> ResourceT m ()
logDebug enter leave = withFrozenCallStack $ do
  RIO.logDebug enter
  toIO (RIO.logDebug leave) >>= register_