resource effect

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))

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' #-}
+

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