From cf2fe0a011bfba89aebc61fd8b2d06c4c51afa74 Mon Sep 17 00:00:00 2001 From: unknown Date: Thu, 31 Oct 2019 12:44:42 +0100 Subject: [PATCH] Improve semantics of Resource --- polysemy.cabal | 3 +- src/Polysemy/Final.hs | 2 +- src/Polysemy/Final/IO.hs | 93 +++++++++ src/Polysemy/Internal/Combinators.hs | 14 +- src/Polysemy/Internal/Union.hs | 4 +- src/Polysemy/Resource.hs | 136 +++++++------ test/BracketSpec.hs | 274 +++++++++++++++++++++++++++ 7 files changed, 461 insertions(+), 65 deletions(-) create mode 100644 src/Polysemy/Final/IO.hs diff --git a/polysemy.cabal b/polysemy.cabal index 0db8b72a..d8c1451d 100644 --- a/polysemy.cabal +++ b/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 diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs index 24319160..9eb70f72 100644 --- a/src/Polysemy/Final.hs +++ b/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 diff --git a/src/Polysemy/Final/IO.hs b/src/Polysemy/Final/IO.hs new file mode 100644 index 00000000..e950df26 --- /dev/null +++ b/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) diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs index 858df1bb..9a19ef96 100644 --- a/src/Polysemy/Internal/Combinators.hs +++ b/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 -> diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs index 4beae597..2914ee87 100644 --- a/src/Polysemy/Internal/Union.hs +++ b/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) diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs index e37a9cd9..225a1921 100644 --- a/src/Polysemy/Resource.hs +++ b/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 #-} diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs index b75109d5..02b04f85 100644 --- a/test/BracketSpec.hs +++ b/test/BracketSpec.hs @@ -1,6 +1,7 @@ module BracketSpec where import Control.Monad +import Data.Either import Polysemy import Polysemy.Error import Polysemy.Output @@ -137,6 +138,93 @@ spec = parallel $ do put "goodbye 1" ) + describe "How effects are dropped by exceptions:" $ do + let + bracketPreserveAllOnNoError = ["alloc pure", "use pure", "dealloc pure"] + bracketOnErrorPreserveAllOnNoError = ["alloc pure", "use pure"] + + preserveAllOn str = [ "alloc " ++ str, "use " ++ str, "dealloc " ++ str ] + loseDeallocOn str = [ "alloc " ++ str, "use " ++ str ] + loseAllOn _str = [] + it "runResource bracket/OnError only protects against pure local exceptions." $ do + let + iosShouldBe = + loseDeallocOn "IO" + ++ loseDeallocOn "global" + ++ preserveAllOn "local" + + globalsShouldBe = + loseAllOn "IO" + ++ loseDeallocOn "global" + ++ preserveAllOn "local" + + localsShouldBe = + loseAllOn "IO" + ++ loseAllOn "global" + ++ loseDeallocOn "local" + runTest4Expecting (runTest4Pure test4Bracket) $ \ios globals locals -> do + ios `shouldBe` bracketPreserveAllOnNoError ++ iosShouldBe + globals `shouldBe` bracketPreserveAllOnNoError ++ globalsShouldBe + locals `shouldBe` bracketPreserveAllOnNoError ++ localsShouldBe + + runTest4Expecting (runTest4Pure test4BracketOnError) $ \ios globals locals -> do + ios `shouldBe` bracketOnErrorPreserveAllOnNoError ++ iosShouldBe + globals `shouldBe` bracketOnErrorPreserveAllOnNoError ++ globalsShouldBe + locals `shouldBe` bracketOnErrorPreserveAllOnNoError ++ localsShouldBe + + it "resourceToIO bracket/OnError protects against IO and pure local exceptions, \ + \ but not pure global ones." $ do + let + iosShouldBe = + preserveAllOn "IO" + ++ loseDeallocOn "global" + ++ preserveAllOn "local" + + globalsShouldBe = + loseAllOn "IO" + ++ loseDeallocOn "global" + ++ preserveAllOn "local" + + localsShouldBe = + loseAllOn "IO" + ++ loseAllOn "global" + ++ loseDeallocOn "local" + runTest4Expecting (runTest4Forklift test4Bracket) $ \ios globals locals -> do + ios `shouldBe` bracketPreserveAllOnNoError ++ iosShouldBe + globals `shouldBe` bracketPreserveAllOnNoError ++ globalsShouldBe + locals `shouldBe` bracketPreserveAllOnNoError ++ localsShouldBe + + runTest4Expecting (runTest4Forklift test4BracketOnError) $ \ios globals locals -> do + ios `shouldBe` bracketOnErrorPreserveAllOnNoError ++ iosShouldBe + globals `shouldBe` bracketOnErrorPreserveAllOnNoError ++ globalsShouldBe + locals `shouldBe` bracketOnErrorPreserveAllOnNoError ++ localsShouldBe + + it "resourceToIOFinal bracket/OnError protects against all kinds of exceptions. \ + \ Effects are preserved according to the table." $ do + let + iosShouldBe = + preserveAllOn "IO" + ++ preserveAllOn "global" + ++ preserveAllOn "local" + + globalsShouldBe = + loseAllOn "IO" + ++ loseDeallocOn "global" + ++ preserveAllOn "local" + + localsShouldBe = + loseAllOn "IO" + ++ loseAllOn "global" + ++ loseDeallocOn "local" + runTest4Expecting (runTest4Final test4Bracket) $ \ios globals locals -> do + ios `shouldBe` bracketPreserveAllOnNoError ++ iosShouldBe + globals `shouldBe` bracketPreserveAllOnNoError ++ globalsShouldBe + locals `shouldBe` bracketPreserveAllOnNoError ++ localsShouldBe + + runTest4Expecting (runTest4Final test4BracketOnError) $ \ios globals locals -> do + ios `shouldBe` bracketOnErrorPreserveAllOnNoError ++ iosShouldBe + globals `shouldBe` bracketOnErrorPreserveAllOnNoError ++ globalsShouldBe + locals `shouldBe` bracketOnErrorPreserveAllOnNoError ++ localsShouldBe ------------------------------------------------------------------------------ @@ -216,3 +304,189 @@ withTransaction m = (trace "beginning transaction") (const $ trace "rolling back transaction") (const $ m <* trace "committing transaction") + + + +runTest4Expecting + :: IO ([String], Either String ([String], Either Bool ([String], Either () ()))) + -> ([String] -> [String] -> [String] -> Expectation) + -> Expectation +runTest4Expecting testRun expectations = do + (ioEffs, rest) <- testRun + rest `shouldSatisfy` isRight + case rest of + Right (globalEffs, rest') -> do + rest' `shouldSatisfy` isRight + case rest' of + Right (localEffs, rest'') -> do + rest'' `shouldBe` Right () + expectations ioEffs globalEffs localEffs + _ -> pure () + _ -> pure () + + +test4Bracket + :: forall r + . Members '[ + Output String -- IO stateful effect + , State [String] -- Global pure stateful effect + , Trace -- Local pure stateful effect + , Error String -- IO exceptions + , Error Bool -- Global exceptions + , Error () -- Local exceptions + , Resource + ] r + => Sem r () +test4Bracket = do + let + record :: String -> Sem r () + record str = do + trace str + modify' (++[str]) + output str + + -- On no exceptions + bracket + (record "alloc pure") + (\_ -> record "dealloc pure") + (\_ -> record "use pure") + + -- On IO exception + bracket + (record "alloc IO") + (\_ -> record "dealloc IO") + (\_ -> record "use IO" >> throw "") + `catch` \"" -> pure () + + -- On global exception + bracket + (record "alloc global") + (\_ -> record "dealloc global") + (\_ -> record "use global" >> throw True) + `catch` \True -> pure () + + -- On local exception + bracket + (record "alloc local") + (\_ -> record "dealloc local") + (\_ -> record "use local" >> throw ()) + `catch` \() -> pure () + +test4BracketOnError + :: forall r + . Members '[ + Output String -- IO stateful effect + , State [String] -- Global pure stateful effect + , Trace -- Local pure stateful effect + , Error String -- IO exceptions + , Error Bool -- Global exceptions + , Error () -- Local exceptions + , Resource + ] r + => Sem r () +test4BracketOnError = do + let + record :: String -> Sem r () + record str = do + trace str + modify' (++[str]) + output str + + -- On no exceptions + bracketOnError + (record "alloc pure") + (\_ -> record "dealloc pure") + (\_ -> record "use pure") + + -- On IO exception + bracketOnError + (record "alloc IO") + (\_ -> record "dealloc IO") + (\_ -> record "use IO" >> throw "") + `catch` \"" -> pure () + + -- On global exception + bracketOnError + (record "alloc global") + (\_ -> record "dealloc global") + (\_ -> record "use global" >> throw True) + `catch` \True -> pure () + + -- On local exception + bracketOnError + (record "alloc local") + (\_ -> record "dealloc local") + (\_ -> record "use local" >> throw ()) + `catch` \() -> pure () + +runTest4Pure + :: Sem '[ + Error () + , Trace + , Resource + , Error Bool + , Output String + , Error String + , State [String] + , Embed IO + , Final IO + ] () + -> IO ([String], Either String ([String], Either Bool ([String], Either () ()))) +runTest4Pure = + runFinal + . embedToFinal + . stateToIO @[String] [] + . errorToIOFinal @String + . runOutputList @String + . runError @Bool + . runResource + . runTraceList + . runError @() + +runTest4Forklift + :: Sem '[ + Error () + , Trace + , Resource + , Error Bool + , Output String + , Error String + , State [String] + , Embed IO + , Final IO + ] () + -> IO ([String], Either String ([String], Either Bool ([String], Either () ()))) +runTest4Forklift = + runFinal + . embedToFinal + . stateToIO @[String] [] + . errorToIOFinal @String + . runOutputList @String + . runError @Bool + . resourceToIO + . runTraceList + . runError @() + +runTest4Final + :: Sem '[ + Error () + , Trace + , Resource + , Error Bool + , Output String + , Error String + , State [String] + , Embed IO + , Final IO + ] () + -> IO ([String], Either String ([String], Either Bool ([String], Either () ()))) +runTest4Final = + runFinal + . embedToFinal + . stateToIO @[String] [] + . errorToIOFinal @String + . runOutputList @String + . runError @Bool + . resourceToIOFinal + . runTraceList + . runError @()