module Control.Effect.Bracket (
EffectBracket, Bracket, runBracket,
Tag, newTag, raiseWith, exceptWith,
Handler, exceptAny, bracket, finally
) where
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Type.Equality ((:~:) (..), TestEquality (..))
import Control.Effect.Witness
import Control.Monad.Effect
data Bracket s a where
Raise :: Tag s b -> b -> Bracket s a
BWitness :: Witness s a -> Bracket s a
data Tag s a = Tag (a -> String) (Token s a)
instance TestEquality (Tag s) where
testEquality (Tag _ i) (Tag _ j) = testEquality i j
type instance Is Bracket f = IsBracket f
type family IsBracket f where
IsBracket (Bracket s) = 'True
IsBracket f = 'False
class MemberEffect Bracket (Bracket s) l => EffectBracket s l
instance MemberEffect Bracket (Bracket s) l => EffectBracket s l
newTag :: EffectBracket s l => (a -> String) -> Effect l (Tag s a)
newTag toString = conceal $ fmap (Tag toString) (rename BWitness newToken)
raiseWith :: EffectBracket s l => Tag s b -> b -> Effect l a
raiseWith tag value = send $ Raise tag value
exceptWith :: EffectBracket s l => Tag s b -> Effect l a -> (b -> Effect l a) -> Effect l a
exceptWith tag effect handler = exceptAny effect [Handler tag handler]
data Handler s l a where
Handler :: Tag s b -> (b -> Effect l a) -> Handler s l a
exceptAny :: EffectBracket s l => Effect l a -> [Handler s l a] -> Effect l a
exceptAny effect handlers = effect `exceptAll` \i x ->
let try (Handler j f) = fmap (\Refl -> f x) (testEquality i j)
results = mapMaybe try handlers
in fromMaybe (raiseWith i x) (listToMaybe results)
exceptAll :: EffectBracket s l => Effect l a -> (forall b. Tag s b -> b -> Effect l a) -> Effect l a
exceptAll effect handler = intercept
return
(\b k ->
case b of
Raise t x -> handler t x
_ -> send b >>= k)
effect
bracket :: EffectBracket s l
=> Effect l a
-> (a -> Effect l ())
-> (a -> Effect l b)
-> Effect l b
bracket acquire destroy run = do
resource <- acquire
result <- run resource `exceptAll` \e x -> do
destroy resource
raiseWith e x
destroy resource
return result
finally :: EffectBracket s l => Effect l a -> Effect l () -> Effect l a
finally effect finalizer = bracket
(return ())
(const finalizer)
(const effect)
runBracket :: (forall s. Effect (Bracket s ':+ l) a) -> Effect l a
runBracket effect = runWitness (convert effect)
convert :: Effect (Bracket s ':+ l) a -> Effect (Witness s ':+ l) a
convert =
eliminate
return
(\t k ->
case t of
Raise (Tag f _) x -> error (f x)
BWitness w -> send w >>= k)
. swap
. extend