monad-finally (empty) → 0.1

raw patch · 5 files changed

+658/−0 lines, 5 filesdep +basedep +monad-abort-fddep +monad-controlsetup-changed

Dependencies added: base, monad-abort-fd, monad-control, transformers, transformers-abort, transformers-base, transformers-compat

Files

LICENSE +27/−0
Setup.hs +2/−0
monad-finally.cabal +43/−0
src/Control/Monad/Exception.hs +285/−0
src/Control/Monad/Finally.hs +301/−0

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) 2011-2017, Mikhail Vorozhtsov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the+  contributors may be used to endorse or promote products derived+  from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ monad-finally.cabal view

@@ -0,0 +1,43 @@+Name: monad-finally+Version: 0.1+Category: Control+Stability: experimental+Synopsis: Guard monadic computations with cleanup actions+Description:+  This package provides a generalized version of @Control.Exception.finally@.+  The cleanup action is run not only on successful termination of the main+  computation and on errors, but on any control flow disruption (e.g.+  @mzero@, short-circuiting) that causes the main computation to not produce+  a result.++Homepage: https://github.com/mvv/monad-finally+Bug-Reports: https://github.com/mvv/monad-finally/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2011-2017 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Tested-With: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2++Cabal-Version: >= 1.6.0+Build-Type: Simple++Source-Repository head+  Type: git+  Location: https://github.com/mvv/monad-finally.git++Library+  Build-Depends: base >= 4.4 && < 5+  Build-Depends: transformers        >= 0.2+               , transformers-compat >= 0.5+               , transformers-base   >= 0.4+               , transformers-abort  >= 0.6+               , monad-abort-fd      >= 0.6+               , monad-control       >= 1.0+  Hs-Source-Dirs: src+  GHC-Options: -Wall+  Exposed-Modules:+    Control.Monad.Finally+    Control.Monad.Exception

+ src/Control/Monad/Exception.hs view

@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | A generalization of "Control.Exception" from the 'IO' monad to+-- 'MonadRecover' 'SomeException'.+module Control.Monad.Exception+  (+  -- * Throwing exceptions+    exception+  , throw+  , throwIO+  , ioError+  , throwTo+  -- * Catching exceptions+  , catch+  , handle+  , catchJust+  , handleJust+  , Handler(..)+  , catches+  , handles+  , try+  , tryJust+  , evaluateIO+  -- * Asynchronous exception control+  , MonadMask(..)+  , liftGetMaskingState+  , liftWithMaskingState+  , mask+  , mask_+  , uninterruptibleMask+  , uninterruptibleMask_+  , interruptible+  , allowInterrupt+  , module Control.Monad.Finally+  , module Control.Exception+  ) where++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#else+import Prelude hiding (ioError)+#endif+import Data.Monoid (Monoid)+import Control.Applicative (Applicative, (<$>))+import Control.Monad (join, liftM)+import Control.Monad.Base+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control (MonadTransControl(..))+import Control.Monad.Trans.Abort hiding (abort, recover)+import Control.Monad.Trans.Finish+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.List+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S+import qualified Control.Monad.Trans.Writer.Lazy as L+import qualified Control.Monad.Trans.Writer.Strict as S+import qualified Control.Monad.Trans.RWS.Lazy as L+import qualified Control.Monad.Trans.RWS.Strict as S+import Control.Monad.Abort.Class+import Control.Monad.Finally+import Control.Concurrent (ThreadId)+import Control.Exception hiding (+  evaluate, throw, throwIO, ioError, throwTo, catch, catchJust, handle,+  handleJust, Handler(..), catches, try, tryJust, finally, onException,+#if !MIN_VERSION_base(4,7,0)+  block, unblock, blocked,+#endif+  getMaskingState, mask, mask_, uninterruptibleMask, uninterruptibleMask_,+#if MIN_VERSION_base(4,9,0)+  interruptible,+#endif+  allowInterrupt, bracket, bracket_, bracketOnError)+import qualified Control.Exception as E+import GHC.Base (maskAsyncExceptions#, maskUninterruptible#,+                 unmaskAsyncExceptions#)+import GHC.IO (IO(..))++-- | Throw an exception from pure code.+exception ∷ Exception e ⇒ e → α+exception = E.throw+{-# INLINE exception #-}++-- | Throw an exception from monadic code. An alias for+-- @'abort' . 'toException'@.+throw ∷ (MonadAbort SomeException μ, Exception e) ⇒ e → μ α+throw = abort . toException+{-# INLINE throw #-}++-- | Thow an exception from the 'IO' monad.+throwIO ∷ (MonadBase IO μ, Exception e) ⇒ e → μ α+throwIO = liftBase . E.throwIO+{-# INLINE throwIO #-}++-- | Raise an 'IOError' in the 'IO' monad.+ioError ∷ MonadBase IO μ ⇒ IOError → μ α+ioError = liftBase . E.ioError+{-# INLINE ioError #-}++-- | Raise an exception in the target thread. See 'E.throwTo'.+throwTo ∷ (MonadBase IO μ, Exception e) ⇒ ThreadId → e → μ ()+throwTo = fmap liftBase . E.throwTo+{-# INLINE throwTo #-}++-- | Recover from the specified type of exceptions.+catch ∷ (MonadRecover SomeException μ, Exception e) ⇒ μ α → (e → μ α) → μ α+catch m h = recover m $ \e → maybe (throw e) h (fromException e)+{-# INLINE catch #-}++-- | An alias for @'flip' 'catch'@.+handle ∷ (MonadRecover SomeException μ, Exception e) ⇒ (e → μ α) → μ α → μ α+handle = flip catch+{-# INLINE handle #-}++-- | Recover from exceptions that satisfy the provided predicate.+catchJust ∷ (MonadRecover SomeException μ, Exception e)+          ⇒ (e → Maybe β) -- ^ Exception predicate+          → μ α           -- ^ Main computation+          → (β → μ α)     -- ^ Exception handler+          → μ α+catchJust f m h = catch m $ \e → maybe (throw e) h $ f e+{-# INLINE catchJust #-}++-- | An alias for @'flip' . 'catchJust'@.+handleJust ∷ (MonadRecover SomeException μ, Exception e)+           ⇒ (e → Maybe β) → (β → μ α) → μ α → μ α+handleJust = flip . catchJust+{-# INLINE handleJust #-}++-- | Exception handler.+data Handler μ α = ∀ e . Exception e ⇒ Handler (e → μ α)++instance Functor μ ⇒ Functor (Handler μ) where+  fmap f (Handler h) = Handler (fmap f . h)+  {-# INLINE fmap #-}++-- | Recover from exceptions by sequentually trying to apply the provided+-- handlers.+catches ∷ MonadRecover SomeException μ ⇒ μ α → [Handler μ α] → μ α+catches m = recover m . hl+  where hl [] e = abort e+        hl (Handler h : hs) e = maybe (hl hs e) h $ fromException e++-- | An alias for @'flip' 'catches'@.+handles ∷ MonadRecover SomeException μ ⇒ [Handler μ α] → μ α → μ α+handles = flip catches+{-# INLINE handles #-}++-- | Recover from exceptions of the spesified type, wrapping them into+-- 'Left'.+try ∷ (MonadRecover SomeException μ, Exception e) ⇒ μ α → μ (Either e α)+try m = catch (Right <$> m) (return . Left)+{-# INLINE try #-}++-- | Recover from exceptions that satisfy the provided predicate, wrapping+-- them into 'Left'.+tryJust ∷ (MonadRecover SomeException μ, Exception e)+        ⇒ (e → Maybe β) -- ^ Exception predicate+        → μ α           -- ^ Main compuration+        → μ (Either β α)+tryJust h m = catch (Right <$> m) $ \e →+  maybe (throw e) (return . Left) (h e)+{-# INLINE tryJust #-}++-- | Evalute the argument to weak head normal form.+evaluateIO ∷ MonadBase IO μ ⇒ α → μ α+evaluateIO = liftBase . E.evaluate+{-# INLINE evaluateIO #-}++-- | A class of monads that support masking of asynchronous exceptions.+class (Applicative μ, Monad μ) ⇒ MonadMask μ where+  -- | Get the current masking state.+  getMaskingState ∷ μ MaskingState+  default getMaskingState ∷ (MonadMask η, MonadTrans t, μ ~ t η)+                          ⇒ μ MaskingState+  getMaskingState = liftGetMaskingState+  {-# INLINE getMaskingState #-}+  -- | Run the provided computation with the specified 'MaskingState'.+  withMaskingState ∷ MaskingState → μ α → μ α+  default withMaskingState ∷ (MonadMask η, MonadTransControl t, μ ~ t η)+                           ⇒ MaskingState → μ α → μ α+  withMaskingState = liftWithMaskingState+  {-# INLINE withMaskingState #-}++-- | Lift 'getMaskingState' through a monad transformer.+liftGetMaskingState ∷ (MonadMask μ, MonadTrans t) ⇒ t μ MaskingState+liftGetMaskingState = lift getMaskingState+{-# INLINE liftGetMaskingState #-}++-- | Lift 'withMaskingState' through a monad transformer.+liftWithMaskingState ∷ (MonadTransControl t, MonadMask μ, Monad (t μ))+                     ⇒ MaskingState → t μ α → t μ α+liftWithMaskingState ms m =+  join $ liftM (restoreT . return) $ liftWith $ \run →+    withMaskingState ms (run m)+{-# INLINE liftWithMaskingState #-}++instance MonadMask IO where+  getMaskingState = E.getMaskingState+  withMaskingState Unmasked (IO io) = IO $ unmaskAsyncExceptions# io+  withMaskingState MaskedInterruptible (IO io) = IO $ maskAsyncExceptions# io+  withMaskingState MaskedUninterruptible (IO io) = IO $ maskUninterruptible# io++instance MonadMask μ ⇒ MonadMask (MaybeT μ)+instance MonadMask μ ⇒ MonadMask (ListT μ)+instance MonadMask μ ⇒ MonadMask (AbortT e μ)+instance MonadMask μ ⇒ MonadMask (FinishT β μ)+instance (MonadMask μ, Error e) ⇒ MonadMask (ErrorT e μ)+instance MonadMask μ ⇒ MonadMask (ExceptT e μ)+instance MonadMask μ ⇒ MonadMask (ReaderT r μ)+instance MonadMask μ ⇒ MonadMask (L.StateT s μ)+instance MonadMask μ ⇒ MonadMask (S.StateT s μ)+instance (MonadMask μ, Monoid w) ⇒ MonadMask (L.WriterT w μ)+instance (MonadMask μ, Monoid w) ⇒ MonadMask (S.WriterT w μ)+instance (MonadMask μ, Monoid w) ⇒ MonadMask (L.RWST r w s μ)+instance (MonadMask μ, Monoid w) ⇒ MonadMask (S.RWST r w s μ)++-- | Prevents asynchronous exceptions from being raised within the provided+-- computation. Blocking operations can still be interrupted. Supplies the+-- computation with @'withMaskingState' s@, where @s@ is the current masking+-- state.+mask ∷ ∀ μ α . MonadMask μ+     ⇒ ((∀ η β . MonadMask η ⇒ η β → η β) → μ α) → μ α+mask f = getMaskingState >>= \case+  Unmasked →+    withMaskingState MaskedInterruptible $ f (withMaskingState Unmasked)+  MaskedInterruptible →+    f (withMaskingState MaskedInterruptible)+  MaskedUninterruptible →+    f (withMaskingState MaskedUninterruptible)+ +-- | An alias for @'mask' . 'const'@.+mask_ ∷ ∀ μ α . MonadMask μ ⇒ μ α → μ α+mask_ = mask . const+{-# INLINE mask_ #-}++-- | Prevents asynchronous exceptions from being raised within the provided+-- computation. Also prevents blocking operations from being interrupted.+-- Supplies the computation with @'withMaskingState' s@, where @s@ is the+-- current masking state.+uninterruptibleMask ∷ MonadMask μ+                    ⇒ ((∀ η β . MonadMask η ⇒ η β → η β) → μ α) → μ α+uninterruptibleMask f = getMaskingState >>= \case+  Unmasked →+    withMaskingState MaskedUninterruptible $ f (withMaskingState Unmasked)+  MaskedInterruptible →+    withMaskingState MaskedUninterruptible $+      f (withMaskingState MaskedInterruptible)+  MaskedUninterruptible →+    f (withMaskingState MaskedUninterruptible)++-- | An alias for @'uninterruptibleMask' . 'const'@.+uninterruptibleMask_ ∷ MonadMask μ ⇒ μ α → μ α+uninterruptibleMask_ = uninterruptibleMask . const+{-# INLINE uninterruptibleMask_ #-}++-- | Allow asynchronous exceptions to be raised within the provided+-- computation, even if the current masking state is 'MaskedInterruptible'+-- (but not in 'MaskedUninterruptible' state).+interruptible ∷ MonadMask μ ⇒ μ α → μ α+interruptible m = getMaskingState >>= \case+  Unmasked → m+  MaskedInterruptible → withMaskingState Unmasked m+  MaskedUninterruptible → m++-- | An alias for @'interruptible' ('return' ())@.+allowInterrupt ∷ MonadMask μ ⇒ μ ()+allowInterrupt = interruptible $ return ()+{-# INLINE allowInterrupt #-}

+ src/Control/Monad/Finally.hs view

@@ -0,0 +1,301 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | Guarding monadic computations with cleanup actions.+module Control.Monad.Finally+  ( MonadFinally(..)+  , chainCleanups+  , finallyMany+  , onEscape+  , onEscapeMany+  , bracket_+  , bracketOnEscape+  ) where++#if !MIN_VERSION_base(4,8,0)+import Prelude hiding (mapM, forM)+#endif+import Data.Functor.Identity+import Data.Monoid (Monoid(..))+import Data.Traversable (mapM, forM)+import Control.Applicative (Applicative(..), (<$>), (<$))+import Control.Monad (join)+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S+import qualified Control.Monad.Trans.Writer.Lazy as LW+import qualified Control.Monad.Trans.Writer.Strict as SW+import qualified Control.Monad.Trans.RWS.Lazy as L+import qualified Control.Monad.Trans.RWS.Strict as S+import Control.Monad.Trans.Abort+import Control.Monad.Trans.Finish+import qualified Control.Exception as E++-- | Class of monads that support guarding computations with cleanup actions.+class (Applicative μ, Monad μ) ⇒ MonadFinally μ where+#if __GLASGOW_HASKELL__ >= 707+  {-# MINIMAL finally' | bracket' #-}+#endif+  -- | @'finally'' m f@ runs computation @m@ and then+  --+  -- 1. runs @f ('Just' x)@ if @m@ produced a result @x@. The result of that is+  -- returned alongside with @x@.+  -- 2. runs @f 'Nothing'@ otherwise.+  finally' ∷ μ α → (Maybe α → μ β) → μ (α, β)+  finally' m f = bracket' (return ()) (const f) (const m)+  -- | A simplified version of 'finally'' in which the cleanup action+  -- does not care about the result of the main computation. The default+  -- implementation is+  --+  -- @+  --     'finally' m = 'fmap' 'fst' . 'finally'' m . 'const'+  -- @+  finally  ∷ μ α → μ β → μ α+  finally m = fmap fst . finally' m . const+  -- | Safely acquire a resource and use it in a computation, releasing it+  -- even when the computation does not produce a result.+  bracket' ∷ μ r                 -- ^ Acquire resource+           → (r → Maybe α → μ β) -- ^ Release resource+           → (r → μ α)           -- ^ Main computation+           → μ (α, β)+  bracket' acquire release m = do+    r ← acquire+    finally' (m r) (release r)+  -- | A simplified version of 'bracket'' in which the releasing action+  -- does not care about the result of the main computation. The default+  -- implementation is+  --+  -- @+  --     'bracket' acquire release =+  --       'fmap' 'fst' . 'bracket'' acquire ('const' . release)+  -- @+  bracket ∷ μ r → (r → μ β) → (r → μ α) → μ α+  bracket acquire release = fmap fst . bracket' acquire (const . release)++instance MonadFinally Identity where+  finally' m f = do+    mr ← m+    return (mr, runIdentity $ f $ Just mr)++instance MonadFinally IO where+  finally' m f = E.mask $ \restore → do+    mr ← restore m `E.onException` f Nothing+    fr ← f $ Just mr+    return (mr, fr)+  bracket' acquire release m = E.mask $ \restore → do+    ar ← acquire+    mr ← restore (m ar) `E.onException` release ar Nothing+    rr ← release ar $ Just mr+    return (mr, rr)++instance MonadFinally μ ⇒ MonadFinally (MaybeT μ) where+  finally' m f = MaybeT $ do+    (mr, fr) ← finally' (runMaybeT m) (runMaybeT . f . join)+    return $ (,) <$> mr <*> fr+  bracket' acquire release m = MaybeT $ do+    (mr, rr) ← bracket' (runMaybeT acquire)+                        (\case+                           Just ar → runMaybeT . release ar . join+                           Nothing → const (return Nothing))+                        (fmap join . mapM (runMaybeT . m))+    return $ (,) <$> mr <*> rr++justRight ∷ Maybe (Either e α) → Maybe α+justRight (Just (Right a)) = Just a+justRight _                = Nothing++instance MonadFinally μ ⇒ MonadFinally (AbortT e μ) where+  finally' m f = AbortT $ do+    (mr, fr) ← finally' (runAbortT m) (runAbortT . f . justRight)+    return $ (,) <$> mr <*> fr+  bracket' acquire release m = AbortT $ do+    (mr, rr) ← bracket' (runAbortT acquire)+                        (\case+                          Right ar → runAbortT . release ar . justRight+                          Left e → const (return (Left e)))+                        (fmap join . mapM (runAbortT . m))+    return $ (,) <$> mr <*> rr++instance MonadFinally μ ⇒ MonadFinally (FinishT β μ) where+  finally' m f = FinishT $ do+    (mr, fr) ← finally' (runFinishT m) (runFinishT . f . justRight)+    return $ (,) <$> mr <*> fr+  bracket' acquire release m = FinishT $ do+    (mr, rr) ← bracket' (runFinishT acquire)+                        (\case+                          Right ar → runFinishT . release ar . justRight+                          Left e → const (return (Left e)))+                        (fmap join . mapM (runFinishT . m))+    return $ (,) <$> mr <*> rr++instance (MonadFinally μ, Error e) ⇒ MonadFinally (ErrorT e μ) where+  finally' m f = ErrorT $ do+    (mr, fr) ← finally' (runErrorT m) (runErrorT . f . justRight)+    return $ (,) <$> mr <*> fr+  bracket' acquire release m = ErrorT $ do+    (mr, rr) ← bracket' (runErrorT acquire)+                        (\case+                          Right ar → runErrorT . release ar . justRight+                          Left e → const (return (Left e)))+                        (fmap join . mapM (runErrorT . m))+    return $ (,) <$> mr <*> rr++instance MonadFinally μ ⇒ MonadFinally (ExceptT e μ) where+  finally' m f = ExceptT $ do+    (mr, fr) ← finally' (runExceptT m) (runExceptT . f . justRight)+    return $ (,) <$> mr <*> fr+  bracket' acquire release m = ExceptT $ do+    (mr, rr) ← bracket' (runExceptT acquire)+                        (\case+                          Right ar → runExceptT . release ar . justRight+                          Left e → const (return (Left e)))+                        (fmap join . mapM (runExceptT . m))+    return $ (,) <$> mr <*> rr++instance MonadFinally μ ⇒ MonadFinally (ReaderT r μ) where+  finally' m f = ReaderT $ \r →+    finally' (runReaderT m r) ((`runReaderT` r) . f)+  bracket' acquire release m = ReaderT $ \r →+    bracket' (runReaderT acquire r)+             (fmap (`runReaderT` r) . release)+             ((`runReaderT` r) . m)++instance MonadFinally μ ⇒ MonadFinally (L.StateT s μ) where+  finally' m f = L.StateT $ \s → do+    ~(~(mr, _), ~(fr, s'')) ← finally' (L.runStateT m s) $ \case+      Just ~(a, s') → L.runStateT (f $ Just a) s'+      Nothing       → L.runStateT (f Nothing) s+    return ((mr, fr), s'')+  bracket' acquire release m = L.StateT $ \s → do+    ~(~(mr, _), ~(fr, s'')) ←+      bracket' (L.runStateT acquire s)+               (\ ~(ar, s') → \case+                  Just ~(mr, s'') → L.runStateT (release ar (Just mr)) s''+                  Nothing         → L.runStateT (release ar Nothing) s')+               (\ ~(ar, s') → L.runStateT (m ar) s')+    return ((mr, fr), s'')++instance MonadFinally μ ⇒ MonadFinally (S.StateT s μ) where+  finally' m f = S.StateT $ \s → do+    ((mr, _), (fr, s''')) ← finally' (S.runStateT m s) $ \case+      Just (a, s') → S.runStateT (f $ Just a) s'+      Nothing      → S.runStateT (f Nothing) s+    return ((mr, fr), s''')+  bracket' acquire release m = S.StateT $ \s → do+    ((mr, _), (fr, s''')) ←+      bracket' (S.runStateT acquire s)+               (\(ar, s') → \case+                  Just ~(mr, s'') → S.runStateT (release ar (Just mr)) s''+                  Nothing         → S.runStateT (release ar Nothing) s')+               (\(ar, s') → S.runStateT (m ar) s')+    return ((mr, fr), s''')++instance (MonadFinally μ, Monoid w) ⇒ MonadFinally (LW.WriterT w μ) where+  finally' m f = LW.WriterT $ do+    ~(~(mr, w), ~(fr, w')) ← finally' (LW.runWriterT m) $+      LW.runWriterT . f . fmap fst+    return ((mr, fr), w `mappend` w')+  bracket' acquire release m = LW.WriterT $ do+    ~(~(mr, w), ~(fr, w')) ←+      bracket' (LW.runWriterT acquire)+               (\ ~(ar, _) → \case+                  Just ~(mr, _) → LW.runWriterT (release ar (Just mr))+                  Nothing → LW.runWriterT (release ar Nothing))+               (\ ~(ar, aw) → LW.runWriterT (LW.tell aw >> m ar))+    return ((mr, fr), w `mappend` w')++instance (MonadFinally μ, Monoid w) ⇒ MonadFinally (SW.WriterT w μ) where+  finally' m f = SW.WriterT $ do+    ((mr, w), (fr, w')) ← finally' (SW.runWriterT m) $ \mbr → case mbr of+      Just (a, _) → SW.runWriterT $ f $ Just a+      Nothing     → SW.runWriterT $ f Nothing+    return ((mr, fr), w `mappend` w')+  bracket' acquire release m = SW.WriterT $ do+    ((mr, w), (fr, w')) ←+      bracket' (SW.runWriterT acquire)+               (\(ar, _) → \case+                  Just (mr, _) → SW.runWriterT (release ar (Just mr))+                  Nothing → SW.runWriterT (release ar Nothing))+               (\(ar, aw) → SW.runWriterT (SW.tell aw >> m ar))+    return ((mr, fr), w `mappend` w')++instance (MonadFinally μ, Monoid w) ⇒ MonadFinally (L.RWST r w s μ) where+  finally' m f = L.RWST $ \r s → do+    ~(~(mr, _, w), ~(fr, s'', w')) ← finally' (L.runRWST m r s) $ \case+      Just ~(mr, s', _) → L.runRWST (f $ Just mr) r s'+      Nothing → L.runRWST (f Nothing) r s+    return ((mr, fr), s'', w `mappend` w')+  bracket' acquire release m = L.RWST $ \r s → do+    ~(~(mr, _, w), ~(fr, s''', w')) ←+      bracket' (L.runRWST acquire r s)+               (\ ~(ar, s', _) → \case +                  Just ~(mr, s'', _) → L.runRWST (release ar $ Just mr) r s''+                  Nothing → L.runRWST (release ar Nothing) r s')+               (\ ~(ar, s', aw) → L.runRWST (L.tell aw >> m ar) r s')+    return ((mr, fr), s''', w `mappend` w')++instance (MonadFinally μ, Monoid w) ⇒ MonadFinally (S.RWST r w s μ) where+  finally' m f = S.RWST $ \r s → do+    ((mr, _, w), (fr, s'', w')) ← finally' (S.runRWST m r s) $ \case+      Just (a, s', _) → S.runRWST (f $ Just a) r s'+      Nothing         → S.runRWST (f Nothing) r s+    return ((mr, fr), s'', w `mappend` w')+  bracket' acquire release m = S.RWST $ \r s → do+    ((mr, _, w), (fr, s''', w')) ←+      bracket' (S.runRWST acquire r s)+               (\(ar, s', _) → \case +                  Just (mr, s'', _) → S.runRWST (release ar $ Just mr) r s''+                  Nothing → S.runRWST (release ar Nothing) r s')+               (\(ar, s', aw) → S.runRWST (S.tell aw >> m ar) r s')+    return ((mr, fr), s''', w `mappend` w')++-- | Run the provided list of cleanup actions sequentually, attempting to run+-- the next action even if the previous one did not produce a result.+chainCleanups ∷ MonadFinally μ ⇒ [μ α] → μ ()+chainCleanups []       = return ()+chainCleanups (m : ms) = finally (() <$ m) $ chainCleanups ms++-- | A variant of 'finally' that combines multiple cleanup actions with+-- 'chainCleanups'.+finallyMany ∷ MonadFinally μ ⇒ μ α → [μ β] → μ α+finallyMany m = finally m . chainCleanups+{-# INLINE finallyMany #-}++-- | @'onEscape' m c@ runs computation @m@ and then, if it did not produce+-- a result, runs computation @c@.+onEscape ∷ MonadFinally μ ⇒ μ α → μ β → μ α+onEscape m f = fmap fst $ finally' m $ maybe (() <$ f) (const $ return ())+{-# INLINE onEscape #-}++-- | A variant of `onEscape` that combines multiple cleanup actions with+-- 'chainCleanups'.+onEscapeMany ∷ MonadFinally μ ⇒ μ α → [μ β] → μ α+onEscapeMany m = onEscape m . chainCleanups++-- | A variant of 'bracket' where acquired value is not needed (e.g. using+-- a static resource).+bracket_ ∷ MonadFinally μ+         ⇒ μ r -- ^ Acquire resource+         → μ β -- ^ Release resource+         → μ α -- ^ Main computation+         → μ α+bracket_ acquire release = bracket acquire (const release) . const+{-# INLINE bracket_ #-}++-- | A variant of 'bracket' that releases the acquired resource only when+-- the main computation does not produce a value.+bracketOnEscape ∷ MonadFinally μ+                ⇒ μ r       -- ^ Acquire resource+                → (r → μ β) -- ^ Release resource+                → (r → μ α) -- ^ Main computation+                → μ α+bracketOnEscape acquire release = fmap fst . bracket' acquire release'+  where release' _  (Just _) = return Nothing+        release' ar Nothing  = Just <$> release ar