Improve semantics of Resource

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.24
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 5fb909edb732407e798db0fa3e2e0a62dbeb807e960b77564b99b34a3235fdb3
+-- hash: bf2638d9cf7c498b6f156bde8cdec3bf423f74085725202354fbdacdfccc67dd
 
 name:           polysemy
 version:        1.2.3.0
@@ -54,6 +54,7 @@ library
       Polysemy.Fail
       Polysemy.Fail.Type
       Polysemy.Final
+      Polysemy.Final.IO
       Polysemy.Fixpoint
       Polysemy.Input
       Polysemy.Internal

src/Polysemy/Final.hs

@@ -182,7 +182,7 @@ withStrategicToFinal strat = withWeavingToFinal (runStrategy strat)
 interpretFinal
     :: forall m e r a
      . Member (Final m) r
-    => (forall x n. e n x -> Strategic m n x)
+    => (forall x n. Monad n => e n x -> Strategic m n x)
        -- ^ A natural transformation from the handled effect to the final monad.
     -> Sem (e ': r) a
     -> Sem r a

src/Polysemy/Final/IO.hs

@@ -0,0 +1,93 @@
+-- | Useful higher-order 'IO' actions lifted to @'Polysemy.Final.Final' 'IO'@.
+--
+-- This module is intended to be imported qualified.
+module Polysemy.Final.IO
+  ( -- * Actions
+    catch
+  , bracket
+  , bracketOnError
+  , mask
+  , onException
+  , finally
+  ) where
+
+import Polysemy
+import Polysemy.Final
+
+import qualified Control.Exception as X
+
+mask :: forall r a
+      . Member (Final IO) r
+     => ((forall x. Sem r x -> Sem r x) -> Sem r a)
+     -> Sem r a
+mask main = withWeavingToFinal $ \s wv _ -> X.mask $ \restore ->
+  let
+    restore' :: forall x. Sem r x -> Sem r x
+    restore' = \m -> withWeavingToFinal $ \s' wv' _ -> restore (wv' (m <$ s'))
+    {-# INLINE restore' #-}
+  in
+    wv (main restore' <$ s)
+
+
+------------------------------------------------------------------------------
+-- | The second branch will execute if the first fails for any reason, be it
+-- an 'IO' exception or an exception of a purely-interpreted effect.
+onException
+  :: Member (Final IO) r
+  => Sem r a
+  -> Sem r b
+  -> Sem r a
+onException m h = withStrategicToFinal $ do
+  m'  <- runS m
+  h'  <- runS h
+  ins <- getInspectorS
+  pure $ do
+    res <- m' `X.onException` h'
+    case inspect ins res of
+      Just _ -> pure res
+      _      -> res <$ h'
+
+finally
+  :: Member (Final IO) r
+  => Sem r a
+  -> Sem r b
+  -> Sem r a
+finally m h = mask $ \restore -> do
+  res <- restore m `onException` h
+  res <$ h
+
+
+bracket
+  :: Member (Final IO) r
+  => Sem r a
+  -> (a -> Sem r b)
+  -> (a -> Sem r c)
+  -> Sem r c
+bracket alloc dealloc use = mask $ \restore -> do
+  a   <- alloc
+  res <- restore (use a) `onException` dealloc a
+  res <$ dealloc a
+
+------------------------------------------------------------------------------
+-- | The deallocation action will execute if the use of the resource fails for
+-- any reason, be it an 'IO' exception or a purely-interpreted effect.
+bracketOnError
+  :: Member (Final IO) r
+  => Sem r a
+  -> (a -> Sem r b)
+  -> (a -> Sem r c)
+  -> Sem r c
+bracketOnError alloc dealloc use = mask $ \restore -> do
+  a   <- alloc
+  restore (use a) `onException` dealloc a
+
+catch
+  :: (X.Exception e, Member (Final IO) r)
+  => Sem r a
+  -> (e -> Sem r a)
+  -> Sem r a
+catch m h = withStrategicToFinal $ do
+  m' <- runS m
+  h' <- bindS h
+  s  <- getInitialStateS
+  pure $ m' `X.catch` \e -> h' (e <$ s)

src/Polysemy/Internal/Combinators.hs

@@ -69,7 +69,7 @@ interpret = firstOrder interpretH
 --
 -- See the notes on 'Tactical' for how to use this function.
 interpretH
-    :: (∀ x m . e m x -> Tactical e m r x)
+    :: (∀ x m . Monad m => e m x -> Tactical e m r x)
        -- ^ A natural transformation from the handled effect to other effects
        -- already in 'Sem'.
     -> Sem (e ': r) a
@@ -156,7 +156,7 @@ lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e
 -- See the notes on 'Tactical' for how to use this function.
 reinterpretH
     :: forall e1 e2 r a
-     . (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)
+     . (∀ m x. Monad m => e1 m x -> Tactical e1 m (e2 ': r) x)
        -- ^ A natural transformation from the handled effect to the new effect.
     -> Sem (e1 ': r) a
     -> Sem (e2 ': r) a
@@ -193,7 +193,7 @@ reinterpret = firstOrder reinterpretH
 -- See the notes on 'Tactical' for how to use this function.
 reinterpret2H
     :: forall e1 e2 e3 r a
-     . (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)
+     . (∀ m x. Monad m => e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)
        -- ^ A natural transformation from the handled effect to the new effects.
     -> Sem (e1 ': r) a
     -> Sem (e2 ': e3 ': r) a
@@ -225,7 +225,7 @@ reinterpret2 = firstOrder reinterpret2H
 -- See the notes on 'Tactical' for how to use this function.
 reinterpret3H
     :: forall e1 e2 e3 e4 r a
-     . (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)
+     . (∀ m x. Monad m => e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)
        -- ^ A natural transformation from the handled effect to the new effects.
     -> Sem (e1 ': r) a
     -> Sem (e2 ': e3 ': e4 ': r) a
@@ -275,7 +275,7 @@ intercept f = interceptH $ \(e :: e m x) -> liftT @m $ f e
 -- See the notes on 'Tactical' for how to use this function.
 interceptH
     :: Member e r
-    => (∀ x m. e m x -> Tactical e m r x)
+    => (∀ x m. Monad m => e m x -> Tactical e m r x)
        -- ^ A natural transformation from the handled effect to other effects
        -- already in 'Sem'.
     -> Sem r a
@@ -296,7 +296,7 @@ interceptH f (Sem m) = Sem $ \k -> m $ \u ->
 -- @since 1.2.3.0
 rewrite
     :: forall e1 e2 r a
-     . (forall m x. e1 m x -> e2 m x)
+     . (forall m x. Monad m => e1 m x -> e2 m x)
     -> Sem (e1 ': r) a
     -> Sem (e2 ': r) a
 rewrite f (Sem m) = Sem $ \k -> m $ \u ->
@@ -313,7 +313,7 @@ rewrite f (Sem m) = Sem $ \k -> m $ \u ->
 transform
     :: forall e1 e2 r a
      . Member e2 r
-    => (forall m x. e1 m x -> e2 m x)
+    => (forall m x. Monad m => e1 m x -> e2 m x)
     -> Sem (e1 ': r) a
     -> Sem r a
 transform f (Sem m) = Sem $ \k -> m $ \u ->

src/Polysemy/Internal/Union.hs

@@ -64,7 +64,7 @@ instance Functor (Union r m) where
 
 data Weaving e m a where
   Weaving
-    :: Functor f
+    :: (Functor f, Monad m)
     =>   { weaveEffect :: e m a
          -- ^ The original effect GADT originally lifted via
          -- 'Polysemy.Internal.send'. There is an invariant that @m ~ Sem r0@,
@@ -233,7 +233,7 @@ weaken (Union n a) = Union (SS n) a
 
 ------------------------------------------------------------------------------
 -- | Lift an effect @e@ into a 'Union' capable of holding it.
-inj :: forall e r m a. (Functor m , Member e r) => e m a -> Union r m a
+inj :: forall e r m a. (Monad m , Member e r) => e m a -> Union r m a
 inj e = injWeaving $
   Weaving e (Identity ())
             (fmap Identity . runIdentity)

src/Polysemy/Resource.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, TupleSections #-}
 
 module Polysemy.Resource
   ( -- * Effect
@@ -19,7 +19,7 @@ module Polysemy.Resource
 
 import qualified Control.Exception as X
 import           Polysemy
-import           Polysemy.Final
+import qualified Polysemy.Final.IO as FinalIO
 
 
 ------------------------------------------------------------------------------
@@ -84,7 +84,7 @@ onException act end = bracketOnError (pure ()) (const end) (const act)
 -- Notably, unlike 'resourceToIO', this is not consistent with
 -- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used.
 -- State that seems like it should be threaded globally throughout 'bracket's
--- /will not be./
+-- /will not be/ if an exception is throw.
 --
 -- Use 'resourceToIO' instead if you need to run
 -- pure, stateful interpreters after the interpreter for 'Resource'.
@@ -95,33 +95,58 @@ onException act end = bracketOnError (pure ()) (const end) (const act)
 resourceToIOFinal :: Member (Final IO) r
                   => Sem (Resource ': r) a
                   -> Sem r a
-resourceToIOFinal = interpretFinal $ \case
+-- KingoftheHomeless: This is implemented such that we preserve
+-- global and local effects as much as possible. This can lead to
+-- strange interactions. See table below for details.
+resourceToIOFinal = interpretH $ \case
   Bracket alloc dealloc use -> do
-    a <- runS  alloc
-    d <- bindS dealloc
-    u <- bindS use
-    pure $ X.bracket a d u
+    a        <- resourceToIOFinal     <$> runT alloc
+    dFailure <- (resourceToIOFinal .) <$> bindT dealloc
+    dSuccess <- (resourceToIOFinal .)
+             <$> bindT (\(resource, res) -> res <$ dealloc resource)
+    u        <- (resourceToIOFinal .)
+             <$> bindT (\resource -> (resource,) <$> use resource)
+    ins      <- getInspectorT
+    raise $ FinalIO.mask $ \restore -> do
+      resource <- a
+      res      <- restore (u resource) `FinalIO.onException` dFailure resource
+      case inspect ins res of
+        Just _ -> dSuccess res
+        _      -> fmap snd res <$ dFailure resource
 
   BracketOnError alloc dealloc use -> do
-    ins <- getInspectorS
-    a <- runS  alloc
-    d <- bindS dealloc
-    u <- bindS use
-    pure $
-      X.bracketOnError
-        a
-        d
-        (\x -> do
-          result <- u x
-          case inspect ins result of
-            Just _ -> pure result
-            Nothing -> do
-              _ <- d x
-              pure result
-        )
-
+    a   <- resourceToIOFinal     <$> runT alloc
+    d   <- (resourceToIOFinal .) <$> bindT dealloc
+    u   <- (resourceToIOFinal .) <$> bindT use
+    ins <- getInspectorT
+    raise $ FinalIO.mask $ \restore -> do
+      resource <- a
+      res <- restore (u resource) `FinalIO.onException` d resource
+      case inspect ins res of
+        Just _ -> pure res
+        _      -> res <$ d resource
 {-# INLINE resourceToIOFinal #-}
 
+{-
+KingoftheHomeless:
+Here's a table of how effects of
+@bracket alloc dealloc use@ or @bracketOnError alloc dealloc use@
+are lost depending on what kind of exception @use@ throws:
+
+                                             Failure Type
+
+                      | IO exception  | Pure global exception | Pure local exception |
+         _____________|_______________|_______________________|______________________|
+               IO     | All preserved |     All preserved     |     All preserved    |
+         _____________|_______________|_______________________|______________________|
+  Effect  Pure global |    All lost   |  dealloc effects lost |     All preserved    |
+   Type  _____________|_______________|_______________________|______________________|
+           Pure local |    All lost   |        All lost       | dealloc effects lost |
+         _____________|_______________|_______________________|______________________|
+
+If no exception is thrown, then all effects will be preserved.
+-}
+
 
 ------------------------------------------------------------------------------
 -- | Run a 'Resource' effect in terms of 'X.bracket'.
@@ -169,15 +194,17 @@ runResource
     -> Sem r a
 runResource = interpretH $ \case
   Bracket alloc dealloc use -> do
-    a <- runT  alloc
-    d <- bindT dealloc
-    u <- bindT use
-
+    a        <- runT  alloc
+    dFailure <- bindT dealloc
+    dSuccess <- bindT (\(resource, res) -> res <$ dealloc resource)
+    u        <- bindT (\resource -> (resource,) <$> use resource)
+    ins      <- getInspectorT
     let run_it = raise . runResource
     resource <- run_it a
     result <- run_it $ u resource
-    _ <- run_it $ d resource
-    pure result
+    case inspect ins result of
+      Just _  -> run_it (dSuccess result)
+      Nothing -> fmap snd result <$ run_it (dFailure resource)
 
   BracketOnError alloc dealloc use -> do
     a <- runT  alloc
@@ -221,38 +248,39 @@ resourceToIO
     => Sem (Resource ': r) a
     -> Sem r a
 resourceToIO = interpretH $ \case
-  Bracket a b c -> do
-    ma <- runT a
-    mb <- bindT b
-    mc <- bindT c
+  Bracket alloc dealloc use -> do
+    a        <- runT alloc
+    dFailure <- bindT dealloc
+    dSuccess <- bindT (\(resource, res) -> res <$ dealloc resource)
+    u        <- bindT (\resource -> (resource,) <$> use resource)
+    ins      <- getInspectorT
 
     withLowerToIO $ \lower finish -> do
       let done :: Sem (Resource ': r) x -> IO x
           done = lower . raise . resourceToIO
-      X.bracket
-          (done ma)
-          (\x -> done (mb x) >> finish)
-          (done . mc)
+      X.mask $ \restore -> do
+        resource <- done a
+        res <- restore (done (u resource))
+               `X.onException` (done (dFailure resource) <* finish)
+        case inspect ins res of
+          Just _ -> done (dSuccess res) <* finish
+          _      -> fmap snd res <$ done (dFailure resource) <* finish
 
-  BracketOnError a b c -> do
+  BracketOnError alloc dealloc use -> do
+    a   <- runT alloc
+    d   <- bindT dealloc
+    u   <- bindT use
     ins <- getInspectorT
-    ma <- runT a
-    mb <- bindT b
-    mc <- bindT c
 
     withLowerToIO $ \lower finish -> do
       let done :: Sem (Resource ': r) x -> IO x
           done = lower . raise . resourceToIO
-      X.bracketOnError
-          (done ma)
-          (\x -> done (mb x) >> finish)
-          (\x -> do
-            result <- done $ mc x
-            case inspect ins result of
-              Just _ -> pure result
-              Nothing -> do
-                _ <- done $ mb x
-                pure result
-          )
+      X.mask $ \restore -> do
+        resource <- done a
+        res <- restore (done (u resource))
+               `X.onException` (done (d resource) <* finish)
+        case inspect ins res of
+          Just _ -> pure res
+          _      -> res <$ done (d resource) <* finish
 {-# INLINE resourceToIO #-}