{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Resource management via 'R.MonadResource'.
module Effectful.Resource
  ( -- * Effect
    Resource

    -- ** Handlers
  , runResource

    -- * Registering and releasing resources
  , R.allocate
  , R.allocate_
  , R.register
  , R.release
  , R.unprotect

    -- * Internal state
  , R.InternalState
  , getInternalState
  , runInternalState
  , R.createInternalState
  , R.closeInternalState
  ) where

import Control.Exception
import qualified Control.Monad.Trans.Resource as R
import qualified Control.Monad.Trans.Resource.Internal as RI

import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive

-- | Provide the ability to use the 'R.MonadResource' instance of 'Eff'.
data Resource :: Effect

type instance DispatchOf Resource = Static WithSideEffects
newtype instance StaticRep Resource = Resource R.InternalState

-- | Run the resource effect.
runResource :: IOE :> es => Eff (Resource : es) a -> Eff es a
runResource :: Eff (Resource : es) a -> Eff es a
runResource Eff (Resource : es) a
m = (Env es -> IO a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es0 -> do
  InternalState
istate <- IO InternalState
forall (m :: Type -> Type). MonadIO m => m InternalState
R.createInternalState
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    Env (Resource : es)
es <- EffectRep (DispatchOf Resource) Resource
-> Relinker (EffectRep (DispatchOf Resource)) Resource
-> Env es
-> IO (Env (Resource : es))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
consEnv (InternalState -> StaticRep Resource
Resource InternalState
istate) Relinker (EffectRep (DispatchOf Resource)) Resource
forall (rep :: ((Type -> Type) -> Type -> Type) -> Type)
       (e :: (Type -> Type) -> Type -> Type).
Relinker rep e
dummyRelinker Env es
es0
    a
a <- IO a -> IO a
forall a. IO a -> IO a
unmask (Eff (Resource : es) a -> Env (Resource : es) -> IO a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff Eff (Resource : es) a
m Env (Resource : es)
es) IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
      Env (Resource : es) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
Env (e : es) -> IO ()
unconsEnv Env (Resource : es)
es
      Maybe SomeException -> InternalState -> IO ()
RI.stateCleanupChecked (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e) InternalState
istate
      SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
    Env (Resource : es) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
Env (e : es) -> IO ()
unconsEnv Env (Resource : es)
es
    Maybe SomeException -> InternalState -> IO ()
RI.stateCleanupChecked Maybe SomeException
forall a. Maybe a
Nothing InternalState
istate
    a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

----------------------------------------
-- Internal state

-- | Get the 'R.InternalState' of the current 'Resource' effect.
getInternalState :: Resource :> es => Eff es R.InternalState
getInternalState :: Eff es InternalState
getInternalState = do
  Resource istate <- Eff es (StaticRep Resource)
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]).
(DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep
  InternalState -> Eff es InternalState
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure InternalState
istate

-- | Run the 'Resource' effect with existing 'R.InternalState'.
--
-- /Note:/ the 'R.InternalState' will not be closed at the end.
runInternalState :: IOE :> es => R.InternalState -> Eff (Resource : es) a -> Eff es a
runInternalState :: InternalState -> Eff (Resource : es) a -> Eff es a
runInternalState InternalState
istate = StaticRep Resource -> Eff (Resource : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(DispatchOf e ~ 'Static sideEffects, MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (InternalState -> StaticRep Resource
Resource InternalState
istate)

----------------------------------------
-- Orphan instance

instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where
  liftResourceT :: ResourceT IO a -> Eff es a
liftResourceT (RI.ResourceT InternalState -> IO a
m) = (Env es -> IO a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
    Env es -> IO (EffectRep (DispatchOf Resource) Resource)
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es IO (StaticRep Resource) -> (StaticRep Resource -> IO a) -> IO a
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Resource istate) -> InternalState -> IO a
m InternalState
istate