diff --git a/src/Definitive/Effect.hs b/src/Definitive/Effect.hs index 5f03244..981ce38 100644 --- a/src/Definitive/Effect.hs +++ b/src/Definitive/Effect.hs @@ -12,7 +12,7 @@ import Data.Functor.Identity class (∀ m. Functor m => Functor (e m)) => Effect e where weave - :: (Functor s, Functor m) + :: (Functor s, Functor m, Functor n) => s () -> (∀ x. s (m x) -> n (s x)) -> e m a @@ -22,6 +22,7 @@ class (∀ m. Functor m => Functor (e m)) => Effect e where :: ( Coercible (e m (s a)) (e n (s a)) , Functor s , Functor m + , Functor n ) => s () -> (∀ x. s (m x) -> n (s x)) diff --git a/src/Definitive/Resource.hs b/src/Definitive/Resource.hs new file mode 100644 index 0000000..d154451 --- /dev/null +++ b/src/Definitive/Resource.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} + +module Definitive.Resource + ( Resource (..) + , bracket + , runResource + ) where + +import qualified Control.Exception as X +import Definitive +import Definitive.Effect +import Control.Monad (void) + + +data Resource m a + = ∀ r x. Bracket (m r) (r -> m ()) (r -> m x) (x -> a) + +deriving instance Functor (Resource m) + +instance Effect Resource where + weave s f (Bracket alloc dealloc use k) = + Bracket (f $ alloc <$ s) + (void . f . fmap dealloc) + (f . fmap use) + (fmap k) + {-# INLINE weave #-} + + hoist f (Bracket alloc dealloc use k) = + Bracket (f alloc) (fmap f dealloc) (fmap f use) k + {-# INLINE hoist #-} + + +bracket + :: Member Resource r + => Def r a + -> (a -> Def r ()) + -> (a -> Def r b) + -> Def r b +bracket alloc dealloc use = send $ Bracket alloc dealloc use id + + +runResource + :: forall r a + . Member (Lift IO) r + => (∀ x. Def r x -> IO x) + -> Def (Resource ': r) a + -> Def r a +runResource finish = interpret $ \case + Bracket alloc dealloc use k -> fmap k . sendM $ + let runIt :: Def (Resource ': r) x -> IO x + runIt = finish . runResource' finish + in X.bracket + (runIt alloc) + (runIt . dealloc) + (runIt . use) +{-# INLINE runResource #-} + + +runResource' + :: Member (Lift IO) r + => (∀ x. Def r x -> IO x) + -> Def (Resource ': r) a + -> Def r a +runResource' = runResource +{-# NOINLINE runResource' #-} + diff --git a/src/Definitive/State.hs b/src/Definitive/State.hs index 22f9cda..1f654fb 100644 --- a/src/Definitive/State.hs +++ b/src/Definitive/State.hs @@ -7,7 +7,13 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} -module Definitive.State where +module Definitive.State + ( State (..) + , get + , put + , modify + , runState + ) where import qualified Control.Monad.Trans.State.Strict as S import Definitive