{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, MultiParamTypeClasses, LambdaCase #-}
{-# LANGUAGE FlexibleContexts, InstanceSigs, NoMonomorphismRestriction, FlexibleInstances #-}
{-# LANGUAGE DataKinds, UndecidableInstances, TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
module Control.Effects.Resource where
import Import hiding (bracket)
import Control.Effects
import Control.Monad.Runnable
import qualified Control.Exception as Ex
import GHC.TypeLits
import qualified Control.Monad.Trans.State.Strict as SS
import qualified Control.Monad.Trans.State.Lazy as LS
import qualified Control.Monad.Trans.Writer.Strict as SW
import qualified Control.Monad.Trans.Writer.Lazy as LW
import qualified Control.Monad.Trans.RWS.Strict as SR
import qualified Control.Monad.Trans.RWS.Lazy as LR
class Unexceptional (t :: (* -> *) -> * -> *)
newtype Bracket m = BracketMethods
{ _bracket ::
forall resource result cleanupRes.
m resource
-> (resource -> Maybe result -> m cleanupRes)
-> (resource -> m result)
-> m result }
instance Effect Bracket where
type CanLift Bracket t = (RunnableTrans t, Unexceptional t)
liftThrough :: forall m t. (RunnableTrans t, Monad (t m), Monad m)
=> Bracket m -> Bracket (t m)
liftThrough (BracketMethods f) = BracketMethods g
where
g :: forall a b c. t m a -> (a -> Maybe c -> t m b) -> (a -> t m c) -> t m c
g acq cleanup use = do
st <- currentTransState
res <- lift (f
(runTransformer acq st)
(\tra mtrc -> flip runTransformer st $ do
a <- restoreTransState tra
c <- case mtrc of
Nothing -> return Nothing
Just trc -> Just <$> restoreTransState trc
cleanup a c)
(\tra -> flip runTransformer st $ do
a <- restoreTransState tra
use a))
restoreTransState res
mergeContext mm = BracketMethods $ \acq cln use -> do
BracketMethods f <- mm
f acq cln use
bracket :: MonadEffect Bracket m =>
m resource -> (resource -> Maybe result -> m cleanupRes) -> (resource -> m result) -> m result
BracketMethods bracket = effect
instance MonadEffect Bracket IO where
effect = BracketMethods $ \acq cln use -> Ex.mask $ \unmasked -> do
resource <- acq
b <- unmasked (use resource) `Ex.catch` \(e :: SomeException) -> do
_ <- cln resource Nothing
throwM e
_ <- cln resource (Just b)
return b
instance MonadEffect Bracket Identity where
effect = BracketMethods $ \acq _ use -> do
res <- acq
use res
instance MonadEffect Bracket m => MonadEffect Bracket (ExceptT e m) where
effect = BracketMethods $ \acq cln use -> do
eres <- lift $ bracket
(runExceptT acq)
(\eres exitCase -> case eres of
Left e -> return (Left e)
Right res -> case exitCase of
Just (Right b) -> runExceptT (cln res (Just b))
_ -> runExceptT (cln res Nothing))
(\case
Right res -> runExceptT $ use res
Left e -> return (Left e))
case eres of
Left e -> throwE e
Right res -> return res
instance MonadEffect Bracket m => MonadEffect Bracket (MaybeT m) where
effect = BracketMethods $ \acq cln use -> do
eres <- lift $ bracket
(runMaybeT acq)
(\mres exitCase -> case mres of
Nothing -> return Nothing
Just res -> case exitCase of
Just (Just b) -> runMaybeT (cln res (Just b))
_ -> runMaybeT (cln res Nothing))
(\case
Just res -> runMaybeT $ use res
Nothing -> return Nothing)
case eres of
Nothing -> mzero
Just res -> return res
instance {-# OVERLAPPABLE #-} UnexceptionalError t => Unexceptional t
instance Unexceptional (SS.StateT s)
instance Unexceptional (LS.StateT s)
instance Unexceptional (SW.WriterT s)
instance Unexceptional (LW.WriterT s)
instance Unexceptional (SR.RWST r w s)
instance Unexceptional (LR.RWST r w s)
instance Unexceptional IdentityT
instance Unexceptional (ReaderT r)
instance Unexceptional (RuntimeImplemented e)
bracket_ :: MonadEffect Bracket m => m resource -> m cleanupRes -> m result -> m result
bracket_ ack cln use = bracket ack (\_ _ -> cln) (const use)
type family UnexceptionalError (t :: (* -> *) -> * -> *) :: Constraint where
UnexceptionalError ListT = TypeError
( 'Text "ListT is an exceptional transformer since it can produce zero results. The reason \
\why it isn't handled like ExceptT or MaybeT is because it's unclear what the behavior should \
\be:"
':$$: 'Text "Firstly, it might acquire more than one resource. Is that expected?"
':$$: 'Text "More importantly, it may produce more than one result of using a single \
\resource. How many times should the cleanup function be called then?"
':$$: 'Text "Also, should all the resources be acquired at the beginning and released at \
\the end, or should they be processed one by one?"
':$$: 'Text "If you need this instance, please let me know what you think should happen." )
UnexceptionalError t = TypeError
( 'Text "The Bracket effect doesn't know about the transformer " ':<>: 'ShowType t ':$$:
'Text "While the effect can be used with any transformer that has a RunnableTrans instance, \
\it's dangerous to do so implicitly because the transformer might introduce an additional \
\exit point to the computation (like IO, MaybeT, ExceptT and friends do)" ':$$:
'Text "If you're sure that it doesn't, give it an 'Unexceptional' instance:" ':$$:
'Text "instance Unexceptional (" ':<>: 'ShowType t ':<>: 'Text ")" )