module Control.Effect.Bracket (
EffectBracket, Bracket, runBracket,
Tag, newTag, raiseWith, exceptWith,
Handler, exceptAny, bracket, finally
) where
import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Type.Equality ((:~:) (..), TestEquality (..))
import Control.Effect.Witness
import Control.Monad.Effect
newtype Bracket s a = Bracket { unBracket :: Union (Raise s :+ Witness s :+ Nil) a }
deriving Functor
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 = mask' $ Tag toString <$> newToken
raiseWith :: EffectBracket s l => Tag s b -> b -> Effect l a
raiseWith tag value = mask' $ 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) = (\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 = mask' $ run $ unmask' effect
where
run = intercept return $ \(Raise t x) -> unmask' (handler t x)
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
$ eliminate return (\(Raise (Tag f _) x) -> error (f x))
$ flatten
$ rename unBracket effect
mask' :: EffectBracket s l => Effect (Raise s :+ Witness s :+ l) a -> Effect l a
mask' = mask Bracket
unmask' :: EffectBracket s l => Effect l a -> Effect (Raise s :+ Witness s :+ l) a
unmask' = unmask unBracket
data Raise s a where
Raise :: Tag s b -> b -> Raise s a
instance Functor (Raise s) where
fmap _ (Raise n x) = Raise n x