runResource via forklift (#130)

This PR adds `runResourceBase` (which is a crap name, but naming things is hard), which interprets `Resource` without the ugly `Sem r ~> IO` parameter. It's a nice solution to #84!

ChangeLog.md

@@ -86,6 +86,9 @@
 
 - Lots of hard work on the package and CI infrastructure to make it green on
     GHC 8.4.4 (thanks to @jkachmar)
+- runResourceBase
 - runTraceAsList
 - New effect: Async
+- Changed the order of the types for `runMonadicInput` to be more helpful
+    (thanks to @tempname11)
 

src/Polysemy/Resource.hs

@@ -13,10 +13,12 @@ module Polysemy.Resource
     -- * Interpretations
   , runResource
   , runResourceInIO
+  , runResourceBase
   ) where
 
 import qualified Control.Exception as X
 import           Polysemy
+import           Polysemy.Internal.Forklift
 
 
 ------------------------------------------------------------------------------
@@ -147,6 +149,55 @@ runResource = interpretH $ \case
 {-# INLINE runResource #-}
 
 
+------------------------------------------------------------------------------
+-- | A more flexible --- though less safe ---  version of 'runResourceInIO'.
+--
+-- This function is capable of running 'Resource' effects anywhere within an
+-- effect stack, without relying on an explicit function to lower it into 'IO'.
+-- Notably, this means that 'Polysemy.State.State' effects will be consistent
+-- in the presence of 'Resource'.
+--
+-- 'runResourceBase' is safe whenever you're concerned about exceptions thrown
+-- by effects _already handled_ in your effect stack, or in 'IO' code run
+-- directly inside of 'bracket'. It is not safe against exceptions thrown
+-- explicitly at the main thread. If this is not safe enough for your use-case,
+-- use 'runResourceInIO' instead.
+--
+-- TODO(sandy): @since version
+runResourceBase
+    :: forall r a
+     . LastMember (Lift IO) r
+    => Sem (Resource ': r) a
+    -> Sem r a
+runResourceBase = interpretH $ \case
+  Bracket a b c -> do
+    ma <- runT a
+    mb <- bindT b
+    mc <- bindT c
+
+    withLowerToIO $ \lower finish -> do
+      let done :: Sem (Resource ': r) x -> IO x
+          done = lower . raise . runResourceBase_b
+      X.bracket
+          (done ma)
+          (\x -> done (mb x) >> finish)
+          (done . mc)
+
+  BracketOnError a b c -> do
+    ma <- runT a
+    mb <- bindT b
+    mc <- bindT c
+
+    withLowerToIO $ \lower finish -> do
+      let done :: Sem (Resource ': r) x -> IO x
+          done = lower . raise . runResourceBase_b
+      X.bracketOnError
+          (done ma)
+          (\x -> done (mb x) >> finish)
+          (done . mc)
+{-# INLINE runResourceBase #-}
+
+
 runResource_b
     :: ∀ r a
      . Sem (Resource ': r) a
@@ -163,3 +214,11 @@ runResourceInIO_b
 runResourceInIO_b = runResourceInIO
 {-# NOINLINE runResourceInIO_b #-}
 
+runResourceBase_b
+    :: forall r a
+     . LastMember (Lift IO) r
+    => Sem (Resource ': r) a
+    -> Sem r a
+runResourceBase_b = runResourceBase
+{-# NOINLINE runResourceBase_b #-}
+

test/BracketSpec.hs

@@ -10,15 +10,23 @@ import Test.Hspec
 
 
 runTest
-  :: Sem '[Error (), Resource, State [Char], Trace, Output String] a
+  :: Sem '[Error (), Resource, State [Char], Trace] a
   -> ([String], ([Char], Either () a))
 runTest = run
-        . runFoldMapOutput @String (:[])
-        . runTraceAsOutput
+        . runTraceAsList
         . runState ""
         . runResource
         . runError @()
 
+runTest2
+  :: Sem '[Error (), Resource, State [Char], Trace, Lift IO] a
+  -> IO ([String], ([Char], Either () a))
+runTest2 = runM
+         . runTraceAsList
+         . runState ""
+         . runResourceBase
+         . runError @()
+
 
 spec :: Spec
 spec = parallel $ do
@@ -80,3 +88,56 @@ spec = parallel $ do
       s `shouldBe` "don't get here"
       e `shouldBe` Right ()
 
+
+  describe "io dispatched bracket" $ do
+    it "persist state and call the finalizer" $ do
+      (ts, (s, e)) <- runTest2 $ do
+            bracket
+              (put "allocated" >> pure ())
+              (\() -> do
+                get >>= trace
+                put "finalized"
+              )
+              (\() -> do
+                get >>= trace
+                put "starting block"
+                _ <- throw ()
+                put "don't get here"
+              )
+      ts `shouldContain` ["allocated"]
+      ts `shouldContain` ["starting block"]
+      s `shouldBe` "finalized"
+      e `shouldBe` Left ()
+
+    it "should not lock when done recursively" $ do
+      (ts, (s, e)) <- runTest2 $ do
+            bracket
+              (put "hello 1")
+              (\() -> do
+                get >>= trace
+                put "finished"
+              )
+              (\() -> do
+                get >>= trace
+                bracket (put "hello 2")
+                        (const $ do
+                          get >>= trace
+                          put "goodbye 2"
+                        )
+                        (const $ do
+                          get >>= trace
+                          put "RUNNING"
+                          throw ()
+                        )
+                -- This doesn't run due to the thrown error above
+                get >>= trace
+                put "goodbye 1"
+              )
+      ts `shouldContain` [ "hello 1"
+                         , "hello 2"
+                         , "RUNNING"
+                         , "goodbye 2"
+                         ]
+      s `shouldBe` "finished"
+      e `shouldBe` Left ()
+