diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,506 @@ +1.0.3.1. + +* Support transformers-0.6 + +1.0.3 + +* Add `controlT` +* Support transformers-compat-0.7 + +1.0.2.4 + + +1.0.2.3 + +* Correct spelling mistake. Courtesy of Edward Betts. + +* Support transformers-compat-0.6. + + +1.0.2.2 + +* Added some good documentation. Courtesy of Franz Thoma. + + +1.0.2.1 + +* Refer to Michael Snoyman's excellent tutorial on monad-control. + + +1.0.2.0 + +* Improve documentation by including type equalities in the Haddock documentation. + +* Add helpers to define MonadTransControl for stack of two: + RunDefault2, defaultLiftWith2, defaultRestoreT2 + +1.0.1.0 + +* Added the functions: + + liftThrough + :: (MonadTransControl t, Monad (t m), Monad m) + => (m (StT t a) -> m (StT t b)) -- ^ + -> t m a -> t m b + + captureT :: (MonadTransControl t, Monad (t m), Monad m) => t m (StT t ()) + captureM :: MonadBaseControl b m => m (StM m ()) + +* Added Travis-CI integration + + +1.0.0.5 + +* Support transformers-0.5 & ransformers-compat-0.5.*. + + +1.0.0.4 + +* Support transformers-compat-0.4.*. + + +1.0.0.3 + +* Unconditionally add ExceptT instances using transformers-compat. + Courtesy of Adam Bergmark. + + +1.0.0.2 + +* Add a base >= 4.5 constraint because monad-control only builds on GHC >= 7.4. + + +1.0.0.1 + +* Use Safe instead of Trustworthy. + + This requires a dependency on stm. + + +1.0.0.0 + +* Switch the associated data types StT and StM to associated type synonyms. + + This is an API breaking change. To fix your MonadTransControl or + MonadBaseControl instances simply remove the StT or StM constructors + and deconstructors for your monad transformers or monad. + +* Add the embed, embed_ and liftBaseOpDiscard functions. + + +0.3.3.1 + +* Unconditionally add ExceptT instances using transformers-compat. + Courtesy of Adam Bergmark. + + +0.3.3.0 + +* Support transformers-0.4.0.0 + +* Drop unicode syntax and symbols + + +0.3.2.3 + +* Fix haddock documentation error + + +0.3.2.2 + +* Fix preprocessor directive for GHC 7.6.3 + + +0.3.2.1 + +* Resolve #14. Bump upper version bound of base to 5 + + +0.3.2 + +* Added defaultLiftWith and defaultRestoreT to simplify defining + MonadTransControl for newtypes. + + +0.3.1.4 + +* Compatibility with ghc head + + +0.3.1.3 + +* Added a Trustworthy flag + + +0.3.1.2 + +* Fix issue #9. Replace all Unicode in type variables. + + +0.3.1.1 + +* Add MonadBaseControl instances for ST and STM. + + +0.3 + +(Released on: Fri Dec 2 09:52:16 UTC 2011) + +* Major new API which IMHO is easier to understand than the old one. + +* On average about 60 times faster than the previous release! + +* New package lifted-base providing lifted versions of functions from the base + library. It exports the following modules: + + - Control.Exception.Lifted + - Control.Concurrent.Lifted + - Control.Concurrent.MVar.Lifted + - System.Timeout.Lifted + + Not all modules from base are converted yet. If you need a lifted version of + some function from base, just ask me to add it or send me a patch. + + +0.2.0.3 + +(Released on: Sat Aug 27 21:18:22 UTC 2011) + +* Fixed issue #2 + https://github.com/basvandijk/monad-control/issues/2 + + +0.2.0.2 + +(Released on: Mon Aug 8 09:16:08 UTC 2011) + +* Switched to git on github. + +* Tested with base-4.4 and ghc-7.2.1. + +* Use the new cabal test-suite feature. + + +0.2.0.1 + +(Released on: Wed Mar 16 15:53:50 UTC 2011) + +* Added laws for MonadTransControl and MonadControlIO + +* Bug fix: Add proper laziness to the MonadTransControl instances + of the lazy StateT, WriteT and RWST + These all failed the law: control $ \run -> run t = t + where t = return undefined + +* Add INLINABLE pragmas for most public functions + A simple benchmark showed some functions + (bracket and mask) improving by 30%. + + +0.2 + +(Released on: Wed Feb 9 12:05:26 UTC 2011) + +* Use RunInBase in the type of idLiftControl. + +* Added this NEWS file. + +* Only parameterize Run with t and use RankNTypes to quantify n and o + -liftControl :: (Monad m, Monad n, Monad o) => (Run t n o -> m a) -> t m a + +liftControl :: Monad m => (Run t -> m a) -> t m a + + -type Run t n o = forall b. t n b -> n (t o b) + +type Run t = forall n o b. (Monad n, Monad o, Monad (t o)) => t n b -> n (t o b) + + Bumped version from 0.1 to 0.2 to indicate this breaking change in API. + +* Added example of a derivation of liftControlIO. + Really enlightening! + + +0.1 + +(Released on: Sat Feb 5 23:36:21 UTC 2011) + +* Initial release + +This is the announcement message sent to the Haskell mailinglists: +http://www.mail-archive.com/haskell@haskell.org/msg23278.html + + +Dear all, + +Several attempts have been made to lift control operations (functions +that use monadic actions as input instead of just output) through +monad transformers: + +MonadCatchIO-transformers[1] provided a type class that allowed to +overload some often used control operations (catch, block and +unblock). Unfortunately that library was limited to those operations. +It was not possible to use, say, alloca in a monad transformer. More +importantly however, the library was broken as was explained[2] by +Michael Snoyman. In response Michael created the MonadInvertIO type +class which solved the problems. Then Anders Kaseorg created the +monad-peel library which provided an even nicer implementation. + +monad-control is a rewrite of monad-peel that uses CPS style +operations and exploits the RankNTypes language extension to simplify +and speedup most functions. A very preliminary and not yet fully +representative, benchmark shows that monad-control is on average about +2.6 times faster than monad-peel: + +bracket: 2.4 x faster +bracket_: 3.1 x faster +catch: 1.8 x faster +try: 4.0 x faster +mask: 2.0 x faster + +Note that, although the package comes with a test suite that passes, I +still consider it highly experimental. + + +API DOCS: + +http://hackage.haskell.org/package/monad-control + + +INSTALLING: + +$ cabal update +$ cabal install monad-control + + +TESTING: + +The package contains a copy of the monad-peel test suite written by +Anders. You can perform the tests using: + +$ cabal unpack monad-control +$ cd monad-control +$ cabal configure -ftest +$ cabal test + + +BENCHMARKING: + +$ darcs get http://bifunctor.homelinux.net/~bas/bench-monad-peel-control/ +$ cd bench-monad-peel-control +$ cabal configure +$ cabal build +$ dist/build/bench-monad-peel-control/bench-monad-peel-control + + +DEVELOPING: + +The darcs repository will be hosted on code.haskell.org ones that +server is back online. For the time being you can get the repository +from: + +$ darcs get http://bifunctor.homelinux.net/~bas/monad-control/ + + +TUTORIAL: + +This short unpolished tutorial will explain how to lift control +operations through monad transformers. Our goal is to lift a control +operation like: + +foo ∷ M a → M a + +where M is some monad, into a transformed monad like 'StateT M': + +foo' ∷ StateT M a → StateT M a + +The first thing we need to do is write an instance for the +MonadTransControl type class: + +class MonadTrans t ⇒ MonadTransControl t where + liftControl ∷ (Monad m, Monad n, Monad o) + ⇒ (Run t n o → m a) → t m a + +If you ignore the Run argument for now, you'll see that liftControl is +identical to the 'lift' method of the MonadTrans type class: + +class MonadTrans t where + lift ∷ Monad m ⇒ m a → t m a + +So the instance for MonadTransControl will probably look very much +like the instance for MonadTrans. Let's see: + +instance MonadTransControl (StateT s) where + liftControl f = StateT $ \s → liftM (\x → (x, s)) (f run) + +So what is this run function? Let's look at its type: + +type Run t n o = ∀ b. t n b → n (t o b) + +The run function executes a transformed monadic action 't n b' in the +non-transformed monad 'n'. In our case the 't' will be a StateT +computation. The only way to run a StateT computation is to give it +some state and the only state we have lying around is the one from the +outer computation: 's'. So let's run it on 's': + +instance MonadTransControl (StateT s) where + liftControl f = + StateT $ \s → + let run t = ... runStateT t s ... + in liftM (\x → (x, s)) (f run) + +Now that we are able to run a transformed monadic action, we're almost +done. Look at the type of Run again. The function should leave the +result 't o b' in the monad 'n'. This 't o b' computation should +contain the final state after running the supplied 't n b' +computation. In case of our StateT it should contain the final state +s': + +instance MonadTransControl (StateT s) where + liftControl f = + StateT $ \s → + let run t = liftM (\(x, s') → StateT $ \_ → return (x, s')) + (runStateT t s) + in liftM (\x → (x, s)) (f run) + +This final computation, "StateT $ \_ → return (x, s')", can later be +used to restore the final state. Now that we have our +MonadTransControl instance we can start using it. Recall that our goal +was to lift "foo ∷ M a → M a" into our StateT transformer yielding the +function "foo' ∷ StateT M a → StateT M a". + +To define foo', the first thing we need to do is call liftControl: + +foo' t = liftControl $ \run → ... + +This captures the current state of the StateT computation and provides +us with the run function that allows us to run a StateT computation on +this captured state. + +Now recall the type of liftControl ∷ (Run t n o → m a) → t m a. You +can see that in place of the ... we must fill in a value of type 'm +a'. In our case this will be a value of type 'M a'. We can construct +such a value by calling foo. However, foo expects an argument of type +'M a'. Fortunately we can provide one if we convert the supplied 't' +computation of type 'StateT M a' to 'M a' using our run function of +type ∀ b. StateT M b → M (StateT o b): + +foo' t = ... liftControl $ \run → foo $ run t + +However, note that the run function returns the final StateT +computation inside M. So the type of the right hand side is now +'StateT M (StateT o b)'. We would like to restore this final state. We +can do that using join: + +foo' t = join $ liftControl $ \run → foo $ run t + +That's it! Note that because it's so common to join after a +liftControl I provide an abstraction for it: + +control = join ∘ liftControl + +Allowing you to simplify foo' to: + +foo' t = control $ \run → foo $ run t + +Probably the most common control operations that you want to lift +through your transformers are IO operations. Think about: bracket, +alloca, mask, etc.. For this reason I provide the MonadControlIO type +class: + +class MonadIO m ⇒ MonadControlIO m where + liftControlIO ∷ (RunInBase m IO → IO a) → m a + +Again, if you ignore the RunInBase argument, you will see that +liftControlIO is identical to the liftIO method of the MonadIO type +class: + +class Monad m ⇒ MonadIO m where + liftIO ∷ IO a → m a + +Just like Run, RunInBase allows you to run your monadic computation +inside your base monad, which in case of liftControlIO is IO: + +type RunInBase m base = ∀ b. m b → base (m b) + +The instance for the base monad is trivial: + +instance MonadControlIO IO where + liftControlIO = idLiftControl + +idLiftControl directly executes f and passes it a run function which +executes the given action and lifts the result r into the trivial +'return r' action: + +idLiftControl ∷ Monad m ⇒ ((∀ b. m b → m (m b)) → m a) → m a +idLiftControl f = f $ liftM $ \r -> return r + +The instances for the transformers are all identical. Let's look at +StateT and ReaderT: + +instance MonadControlIO m ⇒ MonadControlIO (StateT s m) where + liftControlIO = liftLiftControlBase liftControlIO + +instance MonadControlIO m ⇒ MonadControlIO (ReaderT r m) where + liftControlIO = liftLiftControlBase liftControlIO + +The magic function is liftLiftControlBase. This function is used to +compose two liftControl operations, the outer provided by a +MonadTransControl instance and the inner provided as the argument: + +liftLiftControlBase ∷ (MonadTransControl t, Monad base, Monad m, Monad (t m)) + ⇒ ((RunInBase m base → base a) → m a) + → ((RunInBase (t m) base → base a) → t m a) +liftLiftControlBase lftCtrlBase = + \f → liftControl $ \run → + lftCtrlBase $ \runInBase → + f $ liftM (join ∘ lift) ∘ runInBase ∘ run + +Basically it captures the state of the outer monad transformer using +liftControl. Then it captures the state of the inner monad using the +supplied lftCtrlBase function. If you recall the identical definitions +of the liftControlIO methods: 'liftLiftControlBase liftControlIO' you +will see that this lftCtrlBase function is the recursive step of +liftLiftControlBase. If you use 'liftLiftControlBase liftControlIO' in +a stack of monad transformers a chain of liftControl operations is +created: + +liftControl $ \run1 -> liftControl $ \run2 -> liftControl $ \run3 -> ... + +This will recurse until we hit the base monad. Then +liftLiftControlBase will finally run f in the base monad supplying it +with a run function that is able to run a 't m a' computation in the +base monad. It does this by composing the run and runInBase functions. +Note that runInBase is basically the composition: '... ∘ run3 ∘ run2'. + +However, just composing the run and runInBase functions is not enough. +Namely: runInBase ∘ run ∷ ∀ b. t m b → base (m (t m b)) while we need +to have ∀ b. t m b → base (t m b). So we need to lift the 'm (t m b)' +computation inside t yielding: 't m (t m b)' and then join that to get +'t m b'. + +Now that we have our MonadControlIO instances we can start using them. +Let's look at how to lift 'bracket' into a monad supporting +MonadControlIO. Before we do that I define a little convenience +function similar to 'control': + +controlIO = join ∘ liftControlIO + +Bracket just calls controlIO which captures the state of m and +provides us with a runInIO function which allows us to run an m +computation in IO: + +bracket ∷ MonadControlIO m + ⇒ m a → (a → m b) → (a → m c) → m c +bracket before after thing = + controlIO $ \runInIO → + E.bracket (runInIO before) + (\m → runInIO $ m >>= after) + (\m → runInIO $ m >>= thing) + +I welcome any comments, questions or patches. + +Regards, + +Bas + +[1] http://hackage.haskell.org/package/MonadCatchIO-transformers +[2] http://docs.yesodweb.com/blog/invertible-monads-exceptions-allocations/ +[3] http://hackage.haskell.org/package/monad-peel diff --git a/Control/Exception/Control.hs b/Control/Exception/Control.hs deleted file mode 100644 --- a/Control/Exception/Control.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, ExistentialQuantification #-} - -#if MIN_VERSION_base(4,3,0) -{-# LANGUAGE RankNTypes #-} -- for mask -#endif - -{- | -Module : Control.Exception.Control -Copyright : Bas van Dijk, Anders Kaseorg -License : BSD-style - -Maintainer : Bas van Dijk -Stability : experimental -Portability : non-portable (extended exceptions) - -This is a wrapped version of @Control.Exception@ with types generalized -from @IO@ to all monads in 'MonadControlIO'. --} - -module Control.Exception.Control - ( module Control.Exception - - -- * Throwing exceptions - , throwIO, ioError - - -- * Catching exceptions - -- ** The @catch@ functions - , catch, catches, Handler(..), catchJust - - -- ** The @handle@ functions - , handle, handleJust - - -- ** The @try@ functions - , try, tryJust - - -- ** The @evaluate@ function - , evaluate - - -- * Asynchronous Exceptions - -- ** Asynchronous exception control - -- |The following functions allow a thread to control delivery of - -- asynchronous exceptions during a critical region. -#if MIN_VERSION_base(4,3,0) - , mask, mask_ - , uninterruptibleMask, uninterruptibleMask_ - , getMaskingState -#else - , block, unblock -#endif - -#if !MIN_VERSION_base(4,4,0) - , blocked -#endif - -- * Brackets - , bracket, bracket_, bracketOnError - - -- * Utilities - , finally, onException - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Data.Function ( ($) ) -import Data.Either ( Either(Left, Right), either ) -import Data.Maybe ( Maybe ) -import Control.Monad ( Monad, (>>=), return, liftM ) -import System.IO.Error ( IOError ) - -#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__) -import System.IO ( IO ) -#endif - -#if __GLASGOW_HASKELL__ < 700 -import Control.Monad ( fail ) -#endif - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from transformers: -import Control.Monad.IO.Class ( MonadIO, liftIO ) - -import Control.Exception hiding - ( throwIO, ioError - , catch, catches, Handler(..), catchJust - , handle, handleJust - , try, tryJust - , evaluate -#if MIN_VERSION_base(4,3,0) - , mask, mask_ - , uninterruptibleMask, uninterruptibleMask_ - , getMaskingState -#else - , block, unblock -#endif -#if !MIN_VERSION_base(4,4,0) - , blocked -#endif - , bracket, bracket_, bracketOnError - , finally, onException - ) -import qualified Control.Exception as E - -#if !MIN_VERSION_base(4,4,0) -import Data.Bool ( Bool ) -#endif - --- from monad-control (this package): -import Control.Monad.IO.Control ( MonadControlIO - , controlIO - , liftIOOp_ - ) -#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__) -import Control.Monad.IO.Control ( liftIOOp ) -#endif - --------------------------------------------------------------------------------- --- * Throwing exceptions --------------------------------------------------------------------------------- - --- |Generalized version of 'E.throwIO'. -throwIO ∷ (MonadIO m, Exception e) ⇒ e → m α -throwIO = liftIO ∘ E.throwIO - --- |Generalized version of 'E.ioError'. -ioError ∷ MonadIO m ⇒ IOError → m α -ioError = liftIO ∘ E.ioError - - --------------------------------------------------------------------------------- --- * Catching exceptions --------------------------------------------------------------------------------- - --- |Generalized version of 'E.catch'. -{-# INLINABLE catch #-} -catch ∷ (MonadControlIO m, Exception e) - ⇒ m α -- ^ The computation to run - → (e → m α) -- ^ Handler to invoke if an exception is raised - → m α -catch a handler = controlIO $ \runInIO → - E.catch (runInIO a) - (\e → runInIO $ handler e) - --- |Generalized version of 'E.catches'. -{-# INLINABLE catches #-} -catches ∷ MonadControlIO m ⇒ m α → [Handler m α] → m α -catches a handlers = controlIO $ \runInIO → - E.catches (runInIO a) - [ E.Handler $ \e → runInIO $ handler e - | Handler handler ← handlers - ] - --- |Generalized version of 'E.Handler'. -data Handler m α = ∀ e. Exception e ⇒ Handler (e → m α) - --- |Generalized version of 'E.catchJust'. -{-# INLINABLE catchJust #-} -catchJust ∷ (MonadControlIO m, Exception e) - ⇒ (e → Maybe β) -- ^ Predicate to select exceptions - → m α -- ^ Computation to run - → (β → m α) -- ^ Handler - → m α -catchJust p a handler = controlIO $ \runInIO → - E.catchJust p - (runInIO a) - (\e → runInIO (handler e)) - - --------------------------------------------------------------------------------- --- ** The @handle@ functions --------------------------------------------------------------------------------- - --- |Generalized version of 'E.handle'. -{-# INLINABLE handle #-} -handle ∷ (MonadControlIO m, Exception e) ⇒ (e → m α) → m α → m α -handle handler a = controlIO $ \runInIO → - E.handle (\e → runInIO (handler e)) - (runInIO a) - --- |Generalized version of 'E.handleJust'. -{-# INLINABLE handleJust #-} -handleJust ∷ (MonadControlIO m, Exception e) - ⇒ (e → Maybe β) → (β → m α) → m α → m α -handleJust p handler a = controlIO $ \runInIO → - E.handleJust p (\e → runInIO (handler e)) - (runInIO a) - - --------------------------------------------------------------------------------- --- ** The @try@ functions --------------------------------------------------------------------------------- - -sequenceEither ∷ Monad m ⇒ Either e (m α) → m (Either e α) -sequenceEither = either (return ∘ Left) (liftM Right) - --- |Generalized version of 'E.try'. -{-# INLINABLE try #-} -try ∷ (MonadControlIO m, Exception e) ⇒ m α → m (Either e α) -try = liftIOOp_ (liftM sequenceEither ∘ E.try) - --- |Generalized version of 'E.tryJust'. -{-# INLINABLE tryJust #-} -tryJust ∷ (MonadControlIO m, Exception e) ⇒ - (e → Maybe β) → m α → m (Either β α) -tryJust p = liftIOOp_ (liftM sequenceEither ∘ E.tryJust p) - - --------------------------------------------------------------------------------- --- ** The @evaluate@ function --------------------------------------------------------------------------------- - --- |Generalized version of 'E.evaluate'. -evaluate ∷ MonadIO m ⇒ α → m α -evaluate = liftIO ∘ E.evaluate - - --------------------------------------------------------------------------------- --- ** Asynchronous exception control --------------------------------------------------------------------------------- - -#if MIN_VERSION_base(4,3,0) --- |Generalized version of 'E.mask'. -{-# INLINABLE mask #-} -mask ∷ MonadControlIO m ⇒ ((∀ α. m α → m α) → m β) → m β -mask = liftIOOp E.mask ∘ liftRestore - -liftRestore ∷ MonadControlIO m - ⇒ ((∀ α. m α → m α) → β) - → ((∀ α. IO α → IO α) → β) -liftRestore f restore = f $ liftIOOp_ restore - --- |Generalized version of 'E.mask_'. -{-# INLINABLE mask_ #-} -mask_ ∷ MonadControlIO m ⇒ m α → m α -mask_ = liftIOOp_ E.mask_ - --- |Generalized version of 'E.uninterruptibleMask'. -{-# INLINABLE uninterruptibleMask #-} -uninterruptibleMask ∷ MonadControlIO m ⇒ ((∀ α. m α → m α) → m β) → m β -uninterruptibleMask = liftIOOp E.uninterruptibleMask ∘ liftRestore - --- |Generalized version of 'E.uninterruptibleMask_'. -{-# INLINABLE uninterruptibleMask_ #-} -uninterruptibleMask_ ∷ MonadControlIO m ⇒ m α → m α -uninterruptibleMask_ = liftIOOp_ E.uninterruptibleMask_ - --- |Generalized version of 'E.getMaskingState'. -getMaskingState ∷ MonadIO m ⇒ m MaskingState -getMaskingState = liftIO E.getMaskingState -#else --- |Generalized version of 'E.block'. -{-# INLINABLE block #-} -block ∷ MonadControlIO m ⇒ m α → m α -block = liftIOOp_ E.block - --- |Generalized version of 'E.unblock'. -{-# INLINABLE unblock #-} -unblock ∷ MonadControlIO m ⇒ m α → m α -unblock = liftIOOp_ E.unblock -#endif - -#if !MIN_VERSION_base(4,4,0) --- | Generalized version of 'E.blocked'. --- returns @True@ if asynchronous exceptions are blocked in the --- current thread. -blocked ∷ MonadIO m ⇒ m Bool -blocked = liftIO E.blocked -#endif - - --------------------------------------------------------------------------------- --- * Brackets --------------------------------------------------------------------------------- - --- |Generalized version of 'E.bracket'. Note, any monadic side --- effects in @m@ of the \"release\" computation will be discarded; it --- is run only for its side effects in @IO@. --- --- Note that when your @acquire@ and @release@ computations are of type 'IO' --- it will be more efficient to write: --- --- @'liftIOOp' ('E.bracket' acquire release)@ -{-# INLINABLE bracket #-} -bracket ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first (\"acquire resource\") - → (α → m β) -- ^ computation to run last (\"release resource\") - → (α → m γ) -- ^ computation to run in-between - → m γ -bracket before after thing = controlIO $ \runInIO → - E.bracket (runInIO before) - (\m → runInIO $ m >>= after) - (\m → runInIO $ m >>= thing) - --- |Generalized version of 'E.bracket_'. Note, any monadic side --- effects in @m@ of /both/ the \"acquire\" and \"release\" --- computations will be discarded. To keep the monadic side effects --- of the \"acquire\" computation, use 'bracket' with constant --- functions instead. --- --- Note that when your @acquire@ and @release@ computations are of type 'IO' --- it will be more efficient to write: --- --- @'liftIOOp_' ('E.bracket_' acquire release)@ -{-# INLINABLE bracket_ #-} -bracket_ ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first (\"acquire resource\") - → m β -- ^ computation to run last (\"release resource\") - → m γ -- ^ computation to run in-between - → m γ -bracket_ before after thing = controlIO $ \runInIO → - E.bracket_ (runInIO before) - (runInIO after) - (runInIO thing) - --- |Generalized version of 'E.bracketOnError'. Note, any monadic side --- effects in @m@ of the \"release\" computation will be discarded. --- --- Note that when your @acquire@ and @release@ computations are of type 'IO' --- it will be more efficient to write: --- --- @'liftIOOp' ('E.bracketOnError' acquire release)@ -{-# INLINABLE bracketOnError #-} -bracketOnError ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first (\"acquire resource\") - → (α → m β) -- ^ computation to run last (\"release resource\") - → (α → m γ) -- ^ computation to run in-between - → m γ -bracketOnError before after thing = controlIO $ \runInIO → - E.bracketOnError (runInIO before) - (\m → runInIO $ m >>= after) - (\m → runInIO $ m >>= thing) - - --------------------------------------------------------------------------------- --- * Utilities --------------------------------------------------------------------------------- - --- |Generalized version of 'E.finally'. Note, any monadic side --- effects in @m@ of the \"afterward\" computation will be discarded. -{-# INLINABLE finally #-} -finally ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first - → m β -- ^ computation to run afterward (even if an exception was raised) - → m α -finally a sequel = controlIO $ \runInIO → - E.finally (runInIO a) - (runInIO sequel) - --- |Generalized version of 'E.onException'. Note, any monadic side --- effects in @m@ of the \"afterward\" computation will be discarded. -{-# INLINABLE onException #-} -onException ∷ MonadControlIO m ⇒ m α → m β → m α -onException m what = controlIO $ \runInIO → - E.onException (runInIO m) - (runInIO what) - - --- The End --------------------------------------------------------------------- diff --git a/Control/Monad/IO/Control.hs b/Control/Monad/IO/Control.hs deleted file mode 100644 --- a/Control/Monad/IO/Control.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, RankNTypes #-} - -{- | -Module : Control.Monad.IO.Control -Copyright : © Bas van Dijk, Anders Kaseorg, 2011 -License : BSD-style - -Maintainer : Bas van Dijk -Stability : experimental -Portability : Requires RankNTypes - -This module defines the class 'MonadControlIO' of 'IO'-based monads into -which control operations on 'IO' (such as exception catching; see -"Control.Exception.Control") can be lifted. - -'liftIOOp' and 'liftIOOp_' enable convenient lifting of two common -special cases of control operation types. --} - -module Control.Monad.IO.Control - ( MonadControlIO(..) - , controlIO - - , liftIOOp - , liftIOOp_ - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Data.Function ( ($) ) -import Data.Monoid ( Monoid ) -import System.IO ( IO ) -import Control.Monad ( join ) - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from transformers: -import Control.Monad.IO.Class ( MonadIO ) - -import Control.Monad.Trans.Identity ( IdentityT ) -import Control.Monad.Trans.List ( ListT ) -import Control.Monad.Trans.Maybe ( MaybeT ) -import Control.Monad.Trans.Error ( ErrorT, Error ) -import Control.Monad.Trans.Reader ( ReaderT ) -import Control.Monad.Trans.State ( StateT ) -import Control.Monad.Trans.Writer ( WriterT ) -import Control.Monad.Trans.RWS ( RWST ) - -import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) -import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) -import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) - --- from monad-control (this package): -import Control.Monad.Trans.Control ( idLiftControl - , liftLiftControlBase - , RunInBase - ) - - --------------------------------------------------------------------------------- --- MonadControlIO --------------------------------------------------------------------------------- - -{-| -@MonadControlIO@ is the class of 'IO'-based monads supporting an -extra operation 'liftControlIO', enabling control operations on 'IO' to be -lifted into the monad. --} -class MonadIO m ⇒ MonadControlIO m where - {-| - @liftControlIO@ is a version of @liftControl@ that operates through an - arbitrary stack of monad transformers directly to an inner 'IO' - (analagously to how 'liftIO' is a version of @lift@). So it can - be used to lift control operations on 'IO' into any - monad in 'MonadControlIO'. For example: - - @ - foo :: 'IO' a -> 'IO' a - foo' :: 'MonadControlIO' m => m a -> m a - foo' a = 'controlIO' $ \runInIO -> -- runInIO :: m a -> 'IO' (m a) - foo $ runInIO a -- uses foo :: 'IO' (m a) -> 'IO' (m a) - @ - - Instances should satisfy similar laws as the 'MonadIO' laws: - - @liftControlIO . const . return = return@ - - @liftControlIO (const (m >>= f)) = liftControlIO (const m) >>= liftControlIO . const . f@ - - Additionally instances should satisfy: - - @'controlIO' $ \\runInIO -> runInIO m = m@ - -} - liftControlIO ∷ (RunInBase m IO → IO α) → m α - --- | An often used composition: @controlIO = 'join' . 'liftControlIO'@ -{-# INLINABLE controlIO #-} -controlIO ∷ MonadControlIO m ⇒ (RunInBase m IO → IO (m α)) → m α -controlIO = join ∘ liftControlIO - - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- - -instance MonadControlIO IO where - liftControlIO = idLiftControl - -instance MonadControlIO m ⇒ MonadControlIO (IdentityT m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (ListT m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (MaybeT m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Error e, MonadControlIO m) ⇒ MonadControlIO (ErrorT e m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (ReaderT r m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (StateT s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (Strict.StateT s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (WriterT w m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (Strict.WriterT w m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (RWST r w s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (Strict.RWST r w s m) where - liftControlIO = liftLiftControlBase liftControlIO - - --------------------------------------------------------------------------------- --- Convenient lifting of two common special cases of control operation types --------------------------------------------------------------------------------- - -{-| -@liftIOOp@ is a particular application of 'liftControlIO' that allows -lifting control operations of type @(a -> 'IO' b) -> 'IO' b@ -(e.g. @alloca@, @withMVar v@) to -@'MonadControlIO' m => (a -> m b) -> m b@. - -@liftIOOp f = \\g -> 'controlIO' $ \runInIO -> f $ runInIO . g@ --} -{-# INLINABLE liftIOOp #-} -liftIOOp ∷ MonadControlIO m - ⇒ ((α → IO (m β)) → IO (m γ)) - → ((α → m β) → m γ) -liftIOOp f = \g → controlIO $ \runInIO → f $ runInIO ∘ g - -{-| -@liftIOOp_@ is a particular application of 'liftControlIO' that allows -lifting control operations of type @'IO' a -> 'IO' a@ -(e.g. @block@) to @'MonadControlIO' m => m a -> m a@. - -@liftIOOp_ f = \\m -> 'controlIO' $ \runInIO -> f $ runInIO m@ --} -{-# INLINABLE liftIOOp_ #-} -liftIOOp_ ∷ MonadControlIO m - ⇒ (IO (m α) → IO (m β)) - → ( m α → m β) -liftIOOp_ f = \m → controlIO $ \runInIO → f $ runInIO m - - --- The End --------------------------------------------------------------------- diff --git a/Control/Monad/Trans/Control.hs b/Control/Monad/Trans/Control.hs deleted file mode 100644 --- a/Control/Monad/Trans/Control.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, RankNTypes #-} - -{- | -Module : Control.Monad.Trans.Control -Copyright : Bas van Dijk, Anders Kaseorg -License : BSD-style - -Maintainer : Bas van Dijk -Stability : experimental -Portability : Requires RankNTypes - -This module defines the class 'MonadTransControl' of monad transformers -through which control operations can be lifted. Instances are -included for all the standard monad transformers from the -@transformers@ library except @ContT@. - -'idLiftControl' and 'liftLiftControlBase' are provided to assist creation of -@MonadControlIO@-like classes (see "Control.Monad.IO.Control") based on core -monads other than 'IO'. --} - -module Control.Monad.Trans.Control - ( -- * MonadTransControl - MonadTransControl(..) - , Run - , control - - -- * Lifting - , idLiftControl - , RunInBase - , liftLiftControlBase - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Data.Function ( ($) ) -import Data.Monoid ( Monoid, mempty ) -import Control.Monad ( Monad, join, return, liftM ) - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from transformers: -import Control.Monad.Trans.Class ( MonadTrans, lift ) - -import Control.Monad.Trans.Identity ( IdentityT(IdentityT), runIdentityT ) -import Control.Monad.Trans.List ( ListT (ListT), runListT ) -import Control.Monad.Trans.Maybe ( MaybeT (MaybeT), runMaybeT ) -import Control.Monad.Trans.Error ( ErrorT (ErrorT), runErrorT, Error ) -import Control.Monad.Trans.Reader ( ReaderT (ReaderT), runReaderT ) -import Control.Monad.Trans.State ( StateT (StateT), runStateT ) -import Control.Monad.Trans.Writer ( WriterT (WriterT), runWriterT ) -import Control.Monad.Trans.RWS ( RWST (RWST), runRWST ) - -import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST (RWST), runRWST ) -import qualified Control.Monad.Trans.State.Strict as Strict ( StateT (StateT), runStateT ) -import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT(WriterT), runWriterT ) - - --------------------------------------------------------------------------------- --- MonadTransControl --------------------------------------------------------------------------------- - -{-| -@MonadTransControl@ is the class of monad transformers supporting an -extra operation 'liftControl', enabling control operations (functions that -use monadic actions as input instead of just output) to be lifted -through the transformer. --} -class MonadTrans t ⇒ MonadTransControl t where - {-| - @liftControl@ is used to peel off the outer layer of a transformed - monadic action, allowing an transformed action @t m a@ to be - treated as a base action @m a@. - - More precisely, @liftControl@ captures the monadic state of @t@ at the - point where it is bound (in @t m@), yielding a function of type: - - @'Run' t = forall n o b. (Monad n, Monad o) => t n b -> n (t o b)@ - - This function runs a transformed monadic action @t n b@ - in the inner monad @n@ using the captured state, and leaves the - result @t o b@ in the monad @n@ after all side effects in @n@ - have occurred. - - This can be used to lift control operations with types such as - @M a -> M a@ into the transformed monad @t M@: - - @ - instance Monad M - foo :: M a -> M a - foo' :: ('MonadTransControl' t, 'Monad' (t M)) => t M a -> t M a - foo' a = 'control' $ \run -> -- run :: t M a -> M (t M a) - foo $ run a -- uses foo :: M (t M a) -> M (t M a) - @ - - Instances should satisfy similar laws as the 'MonadTrans' laws: - - @liftControl . const . return = return@ - - @liftControl (const (m >>= f)) = liftControl (const m) >>= liftControl . const . f@ - - Additionally instances should satisfy: - - @'control' $ \\run -> run t = t@ - -} - liftControl ∷ Monad m ⇒ (Run t → m α) → t m α - -type Run t = ∀ n o β - . (Monad n, Monad o, Monad (t o)) - ⇒ t n β → n (t o β) - --- | An often used composition: @control = 'join' . 'liftControl'@ -control ∷ (Monad m, Monad (t m), MonadTransControl t) - ⇒ (Run t → m (t m α)) → t m α -control = join ∘ liftControl - - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- - -instance MonadTransControl IdentityT where - liftControl f = IdentityT $ f run - where - run t = liftM return (runIdentityT t) - -instance Error e ⇒ - MonadTransControl (ErrorT e) where liftControl = liftControlNoState ErrorT runErrorT -instance MonadTransControl ListT where liftControl = liftControlNoState ListT runListT -instance MonadTransControl MaybeT where liftControl = liftControlNoState MaybeT runMaybeT - -liftControlNoState ∷ (Monad m, Monad f) - ⇒ (∀ p β. p (f β) → t p β) - → (∀ n β. t n β → n (f β)) - → ((Run t → m α) → t m α) -liftControlNoState mkT runT = \f → mkT $ liftM return $ f $ - liftM (mkT ∘ return) ∘ runT - -instance MonadTransControl (ReaderT r) where - liftControl f = - ReaderT $ \r → - let run t = liftM return (runReaderT t r) - in f run - -instance MonadTransControl (StateT s) where - liftControl f = - StateT $ \s → - let run t = liftM (\ ~(x, s') → StateT $ \_ → return (x, s')) - (runStateT t s) - in liftM (\x → (x, s)) (f run) - -instance MonadTransControl (Strict.StateT s) where - liftControl f = - Strict.StateT $ \s → - let run t = liftM (\(x, s') → Strict.StateT $ \_ → return (x, s')) - (Strict.runStateT t s) - in liftM (\x → (x, s)) (f run) - -instance Monoid w ⇒ MonadTransControl (WriterT w) where - liftControl f = WriterT $ liftM (\x → (x, mempty)) (f run) - where - run t = liftM (\ ~(x, w) → WriterT $ return (x, w)) - (runWriterT t) - -instance Monoid w ⇒ MonadTransControl (Strict.WriterT w) where - liftControl f = Strict.WriterT $ liftM (\x → (x, mempty)) (f run) - where - run t = liftM (\(x, w) → Strict.WriterT $ return (x, w)) - (Strict.runWriterT t) - -instance Monoid w ⇒ MonadTransControl (RWST r w s) where - liftControl f = - RWST $ \r s → - let run t = liftM (\ ~(x, s', w) → RWST $ \_ _ → return (x, s', w)) - (runRWST t r s) - in liftM (\x → (x, s, mempty)) (f run) - -instance Monoid w ⇒ MonadTransControl (Strict.RWST r w s) where - liftControl f = - Strict.RWST $ \r s → - let run t = liftM (\(x, s', w) → Strict.RWST $ \_ _ → return (x, s', w)) - (Strict.runRWST t r s) - in liftM (\x → (x, s, mempty)) (f run) - - --------------------------------------------------------------------------------- --- Lifting --------------------------------------------------------------------------------- - -{-| -@idLiftControl@ acts as the \"identity\" 'liftControl' operation from a monad -@m@ to itself. - -@idLiftControl f = f $ liftM return@ - -It serves as the base case for a class like @MonadControlIO@, which -allows control operations in some base monad (here @IO@) to be -lifted through arbitrary stacks of zero or more monad transformers -in one call. For example, "Control.Monad.IO.Control" defines: - -@ -class MonadIO m => MonadControlIO m where - liftControlIO :: (RunInBase m IO -> IO b) -> m b -@ - -@ -instance MonadControlIO IO where - liftControlIO = idLiftControl -@ --} -idLiftControl ∷ Monad m ⇒ (RunInBase m m → m α) → m α -idLiftControl f = f $ liftM return - -type RunInBase m base = ∀ β. m β → base (m β) - -{-| -@liftLiftControlBase@ is used to compose two 'liftControl' operations: -the outer provided by a 'MonadTransControl' instance, -and the inner provided as the argument. - -It satisfies @'liftLiftControlBase' 'idLiftControl' = 'liftControl'@. - -It serves as the induction step of a @MonadControlIO@-like class. For -example, "Control.Monad.IO.Control" defines: - -@ -instance MonadControlIO m => MonadControlIO (StateT s m) where - liftControlIO = liftLiftControlBase liftControlIO -@ - -using the 'MonadTransControl' instance of @'StateT' s@. - -The following shows the recursive structure of 'liftControlIO' applied to a -stack of three monad transformers with IO as the base monad: @t1 (t2 (t3 IO)) a@: - -@ -liftControlIO - = - 'liftLiftControlBase' $ - 'liftLiftControlBase' $ - 'liftLiftControlBase' $ - 'idLiftControl' - = - \\f -> 'liftControl' $ \\run1 -> -- Capture state of t1, run1 :: 'Run' t1 - 'liftControl' $ \\run2 -> -- Capture state of t2, run2 :: 'Run' t2 - 'liftControl' $ \\run3 -> -- Capture state of t3, run3 :: 'Run' t3 - let run :: 'RunInBase' (t1 (t2 (t3 IO))) IO - run = -- Restore state - 'liftM' ('join' . 'lift') -- :: IO ( t2 (t3 IO) (t1 (t2 (t3 IO)) a)) -> IO ( t1 (t2 (t3 IO)) a) - . 'liftM' ('join' . 'lift') -- :: IO ( t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a))) -> IO ( t2 (t3 IO) (t1 (t2 (t3 IO)) a)) - -- Identity conversion - . 'liftM' ('join' . 'lift') -- :: IO (IO (t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a)))) -> IO ( t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a))) - . 'liftM' 'return' -- :: IO ( t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a))) -> IO (IO (t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a)))) - -- Run (computation to run:) (inner monad:) (restore computation:) - . run3 -- :: t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a)) -> IO (t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a))) - . run2 -- :: t2 (t3 IO) (t1 (t2 (t3 IO)) a) -> t3 IO (t2 (t3 IO) (t1 (t2 (t3 IO)) a)) - . run1 -- :: t1 (t2 (t3 IO)) a -> t2 (t3 IO) (t1 (t2 (t3 IO)) a) - in f run -@ --} -liftLiftControlBase ∷ (MonadTransControl t, Monad (t m), Monad m, Monad base) - ⇒ ((RunInBase m base → base α) → m α) -- ^ @liftControlBase@ operation - → ((RunInBase (t m) base → base α) → t m α) -liftLiftControlBase lftCtrlBase = \f → liftControl $ \run1 → - lftCtrlBase $ \runInBase → - let run = liftM (join ∘ lift) ∘ runInBase ∘ run1 - in f run - - --- The End --------------------------------------------------------------------- diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -1,334 +0,0 @@ -0.2.0.2 - -(Released on: Mon Aug 8 09:16:08 UTC 2011) - -* Switched to git on github. - -* Tested with base-4.4 and ghc-7.2.1. - -* Use the new cabal test-suite feature. - - -0.2.0.1 - -(Released on: Wed Mar 16 15:53:50 UTC 2011) - -* Added laws for MonadTransControl and MonadControlIO - -* Bug fix: Add proper laziness to the MonadTransControl instances - of the lazy StateT, WriteT and RWST - These all failed the law: control $ \run -> run t = t - where t = return undefined - -* Add INLINABLE pragmas for most public functions - A simple benchmark showed some functions - (bracket and mask) improving by 30%. - - -0.2 - -(Released on: Wed Feb 9 12:05:26 UTC 2011) - -* Use RunInBase in the type of idLiftControl. - -* Added this NEWS file. - -* Only parameterize Run with t and use RankNTypes to quantify n and o - -liftControl :: (Monad m, Monad n, Monad o) => (Run t n o -> m a) -> t m a - +liftControl :: Monad m => (Run t -> m a) -> t m a - - -type Run t n o = forall b. t n b -> n (t o b) - +type Run t = forall n o b. (Monad n, Monad o, Monad (t o)) => t n b -> n (t o b) - - Bumped version from 0.1 to 0.2 to indicate this breaking change in API. - -* Added example of a derivation of liftControlIO. - Really enlightening! - - -0.1 - -(Released on: Sat Feb 5 23:36:21 UTC 2011) - -* Initial release - -This is the announcement message sent to the Haskell mailinglists: -http://www.mail-archive.com/haskell@haskell.org/msg23278.html - - -Dear all, - -Several attempts have been made to lift control operations (functions -that use monadic actions as input instead of just output) through -monad transformers: - -MonadCatchIO-transformers[1] provided a type class that allowed to -overload some often used control operations (catch, block and -unblock). Unfortunately that library was limited to those operations. -It was not possible to use, say, alloca in a monad transformer. More -importantly however, the library was broken as was explained[2] by -Michael Snoyman. In response Michael created the MonadInvertIO type -class which solved the problems. Then Anders Kaseorg created the -monad-peel library which provided an even nicer implementation. - -monad-control is a rewrite of monad-peel that uses CPS style -operations and exploits the RankNTypes language extension to simplify -and speedup most functions. A very preliminary and not yet fully -representative, benchmark shows that monad-control is on average about -2.6 times faster than monad-peel: - -bracket: 2.4 x faster -bracket_: 3.1 x faster -catch: 1.8 x faster -try: 4.0 x faster -mask: 2.0 x faster - -Note that, although the package comes with a test suite that passes, I -still consider it highly experimental. - - -API DOCS: - -http://hackage.haskell.org/package/monad-control - - -INSTALLING: - -$ cabal update -$ cabal install monad-control - - -TESTING: - -The package contains a copy of the monad-peel test suite written by -Anders. You can perform the tests using: - -$ cabal unpack monad-control -$ cd monad-control -$ cabal configure -ftest -$ cabal test - - -BENCHMARKING: - -$ darcs get http://bifunctor.homelinux.net/~bas/bench-monad-peel-control/ -$ cd bench-monad-peel-control -$ cabal configure -$ cabal build -$ dist/build/bench-monad-peel-control/bench-monad-peel-control - - -DEVELOPING: - -The darcs repository will be hosted on code.haskell.org ones that -server is back online. For the time being you can get the repository -from: - -$ darcs get http://bifunctor.homelinux.net/~bas/monad-control/ - - -TUTORIAL: - -This short unpolished tutorial will explain how to lift control -operations through monad transformers. Our goal is to lift a control -operation like: - -foo ∷ M a → M a - -where M is some monad, into a transformed monad like 'StateT M': - -foo' ∷ StateT M a → StateT M a - -The first thing we need to do is write an instance for the -MonadTransControl type class: - -class MonadTrans t ⇒ MonadTransControl t where - liftControl ∷ (Monad m, Monad n, Monad o) - ⇒ (Run t n o → m a) → t m a - -If you ignore the Run argument for now, you'll see that liftControl is -identical to the 'lift' method of the MonadTrans type class: - -class MonadTrans t where - lift ∷ Monad m ⇒ m a → t m a - -So the instance for MonadTransControl will probably look very much -like the instance for MonadTrans. Let's see: - -instance MonadTransControl (StateT s) where - liftControl f = StateT $ \s → liftM (\x → (x, s)) (f run) - -So what is this run function? Let's look at its type: - -type Run t n o = ∀ b. t n b → n (t o b) - -The run function executes a transformed monadic action 't n b' in the -non-transformed monad 'n'. In our case the 't' will be a StateT -computation. The only way to run a StateT computation is to give it -some state and the only state we have lying around is the one from the -outer computation: 's'. So let's run it on 's': - -instance MonadTransControl (StateT s) where - liftControl f = - StateT $ \s → - let run t = ... runStateT t s ... - in liftM (\x → (x, s)) (f run) - -Now that we are able to run a transformed monadic action, we're almost -done. Look at the type of Run again. The function should leave the -result 't o b' in the monad 'n'. This 't o b' computation should -contain the final state after running the supplied 't n b' -computation. In case of our StateT it should contain the final state -s': - -instance MonadTransControl (StateT s) where - liftControl f = - StateT $ \s → - let run t = liftM (\(x, s') → StateT $ \_ → return (x, s')) - (runStateT t s) - in liftM (\x → (x, s)) (f run) - -This final computation, "StateT $ \_ → return (x, s')", can later be -used to restore the final state. Now that we have our -MonadTransControl instance we can start using it. Recall that our goal -was to lift "foo ∷ M a → M a" into our StateT transformer yielding the -function "foo' ∷ StateT M a → StateT M a". - -To define foo', the first thing we need to do is call liftControl: - -foo' t = liftControl $ \run → ... - -This captures the current state of the StateT computation and provides -us with the run function that allows us to run a StateT computation on -this captured state. - -Now recall the type of liftControl ∷ (Run t n o → m a) → t m a. You -can see that in place of the ... we must fill in a value of type 'm -a'. In our case this will be a value of type 'M a'. We can construct -such a value by calling foo. However, foo expects an argument of type -'M a'. Fortunately we can provide one if we convert the supplied 't' -computation of type 'StateT M a' to 'M a' using our run function of -type ∀ b. StateT M b → M (StateT o b): - -foo' t = ... liftControl $ \run → foo $ run t - -However, note that the run function returns the final StateT -computation inside M. So the type of the right hand side is now -'StateT M (StateT o b)'. We would like to restore this final state. We -can do that using join: - -foo' t = join $ liftControl $ \run → foo $ run t - -That's it! Note that because it's so common to join after a -liftControl I provide an abstraction for it: - -control = join ∘ liftControl - -Allowing you to simplify foo' to: - -foo' t = control $ \run → foo $ run t - -Probably the most common control operations that you want to lift -through your transformers are IO operations. Think about: bracket, -alloca, mask, etc.. For this reason I provide the MonadControlIO type -class: - -class MonadIO m ⇒ MonadControlIO m where - liftControlIO ∷ (RunInBase m IO → IO a) → m a - -Again, if you ignore the RunInBase argument, you will see that -liftControlIO is identical to the liftIO method of the MonadIO type -class: - -class Monad m ⇒ MonadIO m where - liftIO ∷ IO a → m a - -Just like Run, RunInBase allows you to run your monadic computation -inside your base monad, which in case of liftControlIO is IO: - -type RunInBase m base = ∀ b. m b → base (m b) - -The instance for the base monad is trivial: - -instance MonadControlIO IO where - liftControlIO = idLiftControl - -idLiftControl directly executes f and passes it a run function which -executes the given action and lifts the result r into the trivial -'return r' action: - -idLiftControl ∷ Monad m ⇒ ((∀ b. m b → m (m b)) → m a) → m a -idLiftControl f = f $ liftM $ \r -> return r - -The instances for the transformers are all identical. Let's look at -StateT and ReaderT: - -instance MonadControlIO m ⇒ MonadControlIO (StateT s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (ReaderT r m) where - liftControlIO = liftLiftControlBase liftControlIO - -The magic function is liftLiftControlBase. This function is used to -compose two liftControl operations, the outer provided by a -MonadTransControl instance and the inner provided as the argument: - -liftLiftControlBase ∷ (MonadTransControl t, Monad base, Monad m, Monad (t m)) - ⇒ ((RunInBase m base → base a) → m a) - → ((RunInBase (t m) base → base a) → t m a) -liftLiftControlBase lftCtrlBase = - \f → liftControl $ \run → - lftCtrlBase $ \runInBase → - f $ liftM (join ∘ lift) ∘ runInBase ∘ run - -Basically it captures the state of the outer monad transformer using -liftControl. Then it captures the state of the inner monad using the -supplied lftCtrlBase function. If you recall the identical definitions -of the liftControlIO methods: 'liftLiftControlBase liftControlIO' you -will see that this lftCtrlBase function is the recursive step of -liftLiftControlBase. If you use 'liftLiftControlBase liftControlIO' in -a stack of monad transformers a chain of liftControl operations is -created: - -liftControl $ \run1 -> liftControl $ \run2 -> liftControl $ \run3 -> ... - -This will recurse until we hit the base monad. Then -liftLiftControlBase will finally run f in the base monad supplying it -with a run function that is able to run a 't m a' computation in the -base monad. It does this by composing the run and runInBase functions. -Note that runInBase is basically the composition: '... ∘ run3 ∘ run2'. - -However, just composing the run and runInBase functions is not enough. -Namely: runInBase ∘ run ∷ ∀ b. t m b → base (m (t m b)) while we need -to have ∀ b. t m b → base (t m b). So we need to lift the 'm (t m b)' -computation inside t yielding: 't m (t m b)' and then join that to get -'t m b'. - -Now that we have our MonadControlIO instances we can start using them. -Let's look at how to lift 'bracket' into a monad supporting -MonadControlIO. Before we do that I define a little convenience -function similar to 'control': - -controlIO = join ∘ liftControlIO - -Bracket just calls controlIO which captures the state of m and -provides us with a runInIO function which allows us to run an m -computation in IO: - -bracket ∷ MonadControlIO m - ⇒ m a → (a → m b) → (a → m c) → m c -bracket before after thing = - controlIO $ \runInIO → - E.bracket (runInIO before) - (\m → runInIO $ m >>= after) - (\m → runInIO $ m >>= thing) - -I welcome any comments, questions or patches. - -Regards, - -Bas - -[1] http://hackage.haskell.org/package/MonadCatchIO-transformers -[2] http://docs.yesodweb.com/blog/invertible-monads-exceptions-allocations/ -[3] http://hackage.haskell.org/package/monad-peel diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,19 +1,17 @@ +[![Hackage](https://img.shields.io/hackage/v/monad-control.svg)](https://hackage.haskell.org/package/monad-control) +[![Build Status](https://travis-ci.org/basvandijk/monad-control.svg)](https://travis-ci.org/basvandijk/monad-control) + This package defines the type class `MonadControlIO`, a subset of `MonadIO` into which generic control operations such as `catch` can be lifted from `IO`. Instances are based on monad transformers in `MonadTransControl`, which includes all standard monad transformers in -the `transformers` library except `ContT`. For convenience, it -provides a wrapped version of `Control.Exception` with types -generalized from `IO` to all monads in `MonadControlIO`. +the `transformers` library except `ContT`. Note that this package is a rewrite of Anders Kaseorg's `monad-peel` library. The main difference is that this package provides CPS style operators and exploits the `RankNTypes` language extension to simplify most definitions. -The package includes a copy of the `monad-peel` testsuite written by -Anders Kaseorg The tests can be performed by using `cabal test`. - -[This `critertion`](https://github.com/basvandijk/bench-monad-peel-control) +[This `criterion`](https://github.com/basvandijk/bench-monad-peel-control) based benchmark shows that `monad-control` is on average about 2.5 times faster than `monad-peel`. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,44 +0,0 @@ -#! /usr/bin/env runhaskell - -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} - -module Main (main) where - - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - --- from base -import System.IO ( IO ) - --- from cabal -import Distribution.Simple ( defaultMainWithHooks - , simpleUserHooks - , UserHooks(haddockHook) - ) - -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Program ( userSpecifyArgs ) -import Distribution.Simple.Setup ( HaddockFlags ) -import Distribution.PackageDescription ( PackageDescription(..) ) - - -------------------------------------------------------------------------------- --- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. -------------------------------------------------------------------------------- - -main ∷ IO () -main = defaultMainWithHooks hooks - where - hooks = simpleUserHooks { haddockHook = haddockHook' } - --- Define __HADDOCK__ for CPP when running haddock. -haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO () -haddockHook' pkg lbi = - haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) - where - p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) - - --- The End --------------------------------------------------------------------- diff --git a/monad-control.cabal b/monad-control.cabal --- a/monad-control.cabal +++ b/monad-control.cabal @@ -1,43 +1,53 @@ -Name: monad-control -Version: 0.2.0.3 -Synopsis: Lift control operations, like exception catching, through monad transformers -Description: - This package defines the type class @MonadControlIO@, a subset of - @MonadIO@ into which generic control operations such as @catch@ can - be lifted from @IO@. Instances are based on monad transformers in - @MonadTransControl@, which includes all standard monad transformers - in the @transformers@ library except @ContT@. For convenience, it - provides a wrapped version of @Control.Exception@ with types - generalized from @IO@ to all monads in @MonadControlIO@. - . - Note that this package is a rewrite of Anders Kaseorg's @monad-peel@ library. - The main difference is that this package provides CPS style - operators and exploits the @RankNTypes@ language extension to - simplify most definitions. - . - The package includes a copy of the @monad-peel@ testsuite written by Anders Kaseorg. - The tests can be performed by using @cabal test@. +name: monad-control +version: 1.0.3.1 +synopsis: + Lift control operations, like exception catching, through monad transformers + +license: BSD3 +license-file: LICENSE +author: Bas van Dijk, Anders Kaseorg +maintainer: + Oleg Grenrus , Bas van Dijk + +copyright: (c) 2011 Bas van Dijk, Anders Kaseorg +homepage: https://github.com/basvandijk/monad-control +bug-reports: https://github.com/basvandijk/monad-control/issues +category: Control +build-type: Simple +cabal-version: 1.12 +description: + This package defines the type class @MonadBaseControl@, a subset of + @MonadBase@ into which generic control operations such as @catch@ can be + lifted from @IO@ or any other base monad. Instances are based on monad + transformers in @MonadTransControl@, which includes all standard monad + transformers in the @transformers@ library except @ContT@. . - The following @critertion@ based benchmark shows that @monad-control@ - is on average about 2.5 times faster than @monad-peel@: + See the + package which uses @monad-control@ to lift @IO@ + operations from the @base@ library (like @catch@ or @bracket@) into any monad + that is an instance of @MonadBase@ or @MonadBaseControl@. . - - -License: BSD3 -License-file: LICENSE -Author: Bas van Dijk, Anders Kaseorg -Maintainer: Bas van Dijk -Copyright: (c) 2011 Bas van Dijk, Anders Kaseorg -Homepage: https://github.com/basvandijk/monad-control/ -Bug-reports: https://github.com/basvandijk/monad-control/issues -Category: Control -Build-type: Custom -Cabal-version: >= 1.9.2 + Note that this package is a rewrite of Anders Kaseorg's @monad-peel@ + library. The main difference is that this package provides CPS style operators + and exploits the @RankNTypes@ and @TypeFamilies@ language extensions to + simplify and speedup most definitions. -extra-source-files: README.markdown, NEWS +extra-source-files: + CHANGELOG + README.markdown --- TODO: Remove when http://hackage.haskell.org/trac/hackage/ticket/792 is fixed: -extra-source-files: test.hs +tested-with: + GHC ==7.4.2 + || ==7.6.3 + || ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.4 + || ==9.0.1 -------------------------------------------------------------------------------- @@ -47,30 +57,14 @@ -------------------------------------------------------------------------------- -Library - Exposed-modules: Control.Monad.Trans.Control - Control.Monad.IO.Control - Control.Exception.Control - - Build-depends: base >= 3 && < 4.5 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , transformers >= 0.2 && < 0.3 - - Ghc-options: -Wall - --------------------------------------------------------------------------------- - -test-suite test-threads - type: exitcode-stdio-1.0 - main-is: test.hs - - ghc-options: -Wall - - build-depends: base >= 3 && < 4.5 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , transformers >= 0.2 && < 0.3 - , HUnit >= 1.2.2 && < 1.3 - , test-framework >= 0.2.4 && < 0.5 - , test-framework-hunit >= 0.2.4 && < 0.3 - --------------------------------------------------------------------------------- +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Control.Monad.Trans.Control + build-depends: + base >=4.5 && <5 + , stm >=2.3 && <3 + , transformers >=0.2 && <0.7 + , transformers-base >=0.4.4 && <0.5 + , transformers-compat >=0.3 && <0.8 diff --git a/src/Control/Monad/Trans/Control.hs b/src/Control/Monad/Trans/Control.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Control.hs @@ -0,0 +1,872 @@ +{-# LANGUAGE CPP + , NoImplicitPrelude + , RankNTypes + , TypeFamilies + , FunctionalDependencies + , FlexibleInstances + , UndecidableInstances + , MultiParamTypeClasses #-} + +{-# LANGUAGE Safe #-} + +#if MIN_VERSION_transformers(0,4,0) +-- Hide warnings for the deprecated ErrorT transformer: +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +#endif + +{- | +Copyright : Bas van Dijk, Anders Kaseorg +License : BSD3 +Maintainer : Bas van Dijk + +This module defines the type class 'MonadBaseControl', a subset of +'MonadBase' into which generic control operations such as @catch@ can be +lifted from @IO@ or any other base monad. Instances are based on monad +transformers in 'MonadTransControl', which includes all standard monad +transformers in the @transformers@ library except @ContT@. + +See the +package which uses @monad-control@ to lift @IO@ +operations from the @base@ library (like @catch@ or @bracket@) into any monad +that is an instance of @MonadBase@ or @MonadBaseControl@. + +See the following tutorial by Michael Snoyman on how to use this package: + + + +=== Quick implementation guide + +Given a base monad @B@ and a stack of transformers @T@: + +* Define instances @'MonadTransControl' T@ for all transformers @T@, using the + @'defaultLiftWith'@ and @'defaultRestoreT'@ functions on the constructor and + deconstructor of @T@. + +* Define an instance @'MonadBaseControl' B B@ for the base monad: + + @ + instance MonadBaseControl B B where + type StM B a = a + liftBaseWith f = f 'id' + restoreM = 'return' + @ + +* Define instances @'MonadBaseControl' B m => 'MonadBaseControl' B (T m)@ for + all transformers: + + @ + instance MonadBaseControl b m => MonadBaseControl b (T m) where + type StM (T m) a = 'ComposeSt' T m a + liftBaseWith f = 'defaultLiftBaseWith' + restoreM = 'defaultRestoreM' + @ +-} + +module Control.Monad.Trans.Control + ( -- * MonadTransControl + MonadTransControl(..), Run + + -- ** Defaults + -- $MonadTransControlDefaults + , RunDefault, defaultLiftWith, defaultRestoreT + -- *** Defaults for a stack of two + -- $MonadTransControlDefaults2 + , RunDefault2, defaultLiftWith2, defaultRestoreT2 + + -- * MonadBaseControl + , MonadBaseControl (..), RunInBase + + -- ** Defaults + -- $MonadBaseControlDefaults + , ComposeSt, RunInBaseDefault, defaultLiftBaseWith, defaultRestoreM + + -- * Utility functions + , control, controlT, embed, embed_, captureT, captureM + + , liftBaseOp, liftBaseOp_ + + , liftBaseDiscard, liftBaseOpDiscard + + , liftThrough + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Function ( (.), ($), const ) +import Data.Monoid ( Monoid, mempty ) +import Control.Monad ( Monad, (>>=), return, liftM ) +import System.IO ( IO ) +import Data.Maybe ( Maybe ) +import Data.Either ( Either ) +import Control.Monad ( void ) +import Prelude ( id ) + +import Control.Monad.ST.Lazy.Safe ( ST ) +import qualified Control.Monad.ST.Safe as Strict ( ST ) + +-- from stm: +import Control.Monad.STM ( STM ) + +-- from transformers: +import Control.Monad.Trans.Class ( MonadTrans ) + +import Control.Monad.Trans.Identity ( IdentityT(IdentityT), runIdentityT ) +import Control.Monad.Trans.Maybe ( MaybeT (MaybeT), runMaybeT ) +import Control.Monad.Trans.Reader ( ReaderT (ReaderT), runReaderT ) +import Control.Monad.Trans.State ( StateT (StateT), runStateT ) +import Control.Monad.Trans.Writer ( WriterT (WriterT), runWriterT ) +import Control.Monad.Trans.RWS ( RWST (RWST), runRWST ) +import Control.Monad.Trans.Except ( ExceptT (ExceptT), runExceptT ) + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.List ( ListT (ListT), runListT ) +import Control.Monad.Trans.Error ( ErrorT (ErrorT), runErrorT, Error ) +#endif + +import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST (RWST), runRWST ) +import qualified Control.Monad.Trans.State.Strict as Strict ( StateT (StateT), runStateT ) +import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT(WriterT), runWriterT ) + +import Data.Functor.Identity ( Identity ) + +-- from transformers-base: +import Control.Monad.Base ( MonadBase ) + + +-------------------------------------------------------------------------------- +-- MonadTransControl type class +-------------------------------------------------------------------------------- + +-- | The @MonadTransControl@ type class is a stronger version of @'MonadTrans'@: +-- +-- Instances of @'MonadTrans'@ know how to @'lift'@ actions in the base monad to +-- the transformed monad. These lifted actions, however, are completely unaware +-- of the monadic state added by the transformer. +-- +-- @'MonadTransControl'@ instances are aware of the monadic state of the +-- transformer and allow to save and restore this state. +-- +-- This allows to lift functions that have a monad transformer in both positive +-- and negative position. Take, for example, the function +-- +-- @ +-- withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +-- @ +-- +-- @'MonadTrans'@ instances can only lift the return type of the @withFile@ +-- function: +-- +-- @ +-- withFileLifted :: MonadTrans t => FilePath -> IOMode -> (Handle -> IO r) -> t IO r +-- withFileLifted file mode action = lift (withFile file mode action) +-- @ +-- +-- However, @'MonadTrans'@ is not powerful enough to make @withFileLifted@ +-- accept a function that returns @t IO@. The reason is that we need to take +-- away the transformer layer in order to pass the function to @'withFile'@. +-- @'MonadTransControl'@ allows us to do this: +-- +-- @ +-- withFileLifted' :: (Monad (t IO), MonadTransControl t) => FilePath -> IOMode -> (Handle -> t IO r) -> t IO r +-- withFileLifted' file mode action = liftWith (\\run -> withFile file mode (run . action)) >>= restoreT . return +-- @ +class MonadTrans t => MonadTransControl t where + -- | Monadic state of @t@. + -- + -- The monadic state of a monad transformer is the result type of its @run@ + -- function, e.g.: + -- + -- @ + -- 'runReaderT' :: 'ReaderT' r m a -> r -> m a + -- 'StT' ('ReaderT' r) a ~ a + -- + -- 'runStateT' :: 'StateT' s m a -> s -> m (a, s) + -- 'StT' ('StateT' s) a ~ (a, s) + -- + -- 'runMaybeT' :: 'MaybeT' m a -> m ('Maybe' a) + -- 'StT' 'MaybeT' a ~ 'Maybe' a + -- @ + -- + -- Provided type instances: + -- + -- @ + -- StT 'IdentityT' a ~ a + -- StT 'MaybeT' a ~ 'Maybe' a + -- StT ('ErrorT' e) a ~ 'Error' e => 'Either' e a + -- StT ('ExceptT' e) a ~ 'Either' e a + -- StT 'ListT' a ~ [a] + -- StT ('ReaderT' r) a ~ a + -- StT ('StateT' s) a ~ (a, s) + -- StT ('WriterT' w) a ~ 'Monoid' w => (a, w) + -- StT ('RWST' r w s) a ~ 'Monoid' w => (a, s, w) + -- @ + type StT t a :: * + + -- | @liftWith@ is similar to 'lift' in that it lifts a computation from + -- the argument monad to the constructed monad. + -- + -- Instances should satisfy similar laws as the 'MonadTrans' laws: + -- + -- @liftWith (\\_ -> return a) = return a@ + -- + -- @liftWith (\\_ -> m >>= f) = liftWith (\\_ -> m) >>= (\\a -> liftWith (\\_ -> f a))@ + -- + -- The difference with 'lift' is that before lifting the @m@ computation + -- @liftWith@ captures the state of @t@. It then provides the @m@ + -- computation with a 'Run' function that allows running @t n@ computations in + -- @n@ (for all @n@) on the captured state, e.g. + -- + -- @ + -- withFileLifted :: (Monad (t IO), MonadTransControl t) => FilePath -> IOMode -> (Handle -> t IO r) -> t IO r + -- withFileLifted file mode action = liftWith (\\run -> withFile file mode (run . action)) >>= restoreT . return + -- @ + -- + -- If the @Run@ function is ignored, @liftWith@ coincides with @lift@: + -- + -- @lift f = liftWith (\\_ -> f)@ + -- + -- Implementations use the @'Run'@ function associated with a transformer: + -- + -- @ + -- liftWith :: 'Monad' m => (('Monad' n => 'ReaderT' r n b -> n b) -> m a) -> 'ReaderT' r m a + -- liftWith f = 'ReaderT' (\\r -> f (\\action -> 'runReaderT' action r)) + -- + -- liftWith :: 'Monad' m => (('Monad' n => 'StateT' s n b -> n (b, s)) -> m a) -> 'StateT' s m a + -- liftWith f = 'StateT' (\\s -> 'liftM' (\\x -> (x, s)) (f (\\action -> 'runStateT' action s))) + -- + -- liftWith :: 'Monad' m => (('Monad' n => 'MaybeT' n b -> n ('Maybe' b)) -> m a) -> 'MaybeT' m a + -- liftWith f = 'MaybeT' ('liftM' 'Just' (f 'runMaybeT')) + -- @ + liftWith :: Monad m => (Run t -> m a) -> t m a + + -- | Construct a @t@ computation from the monadic state of @t@ that is + -- returned from a 'Run' function. + -- + -- Instances should satisfy: + -- + -- @liftWith (\\run -> run t) >>= restoreT . return = t@ + -- + -- @restoreT@ is usually implemented through the constructor of the monad + -- transformer: + -- + -- @ + -- 'ReaderT' :: (r -> m a) -> 'ReaderT' r m a + -- restoreT :: m a -> 'ReaderT' r m a + -- restoreT action = 'ReaderT' { runReaderT = 'const' action } + -- + -- 'StateT' :: (s -> m (a, s)) -> 'StateT' s m a + -- restoreT :: m (a, s) -> 'StateT' s m a + -- restoreT action = 'StateT' { runStateT = 'const' action } + -- + -- 'MaybeT' :: m ('Maybe' a) -> 'MaybeT' m a + -- restoreT :: m ('Maybe' a) -> 'MaybeT' m a + -- restoreT action = 'MaybeT' action + -- @ + -- + -- Example type signatures: + -- + -- @ + -- restoreT :: 'Monad' m => m a -> 'IdentityT' m a + -- restoreT :: 'Monad' m => m ('Maybe' a) -> 'MaybeT' m a + -- restoreT :: ('Monad' m, 'Error' e) => m ('Either' e a) -> 'ErrorT' e m a + -- restoreT :: 'Monad' m => m ('Either' e a) -> 'ExceptT' e m a + -- restoreT :: 'Monad' m => m [a] -> 'ListT' m a + -- restoreT :: 'Monad' m => m a -> 'ReaderT' r m a + -- restoreT :: 'Monad' m => m (a, s) -> 'StateT' s m a + -- restoreT :: ('Monad' m, 'Monoid' w) => m (a, w) -> 'WriterT' w m a + -- restoreT :: ('Monad' m, 'Monoid' w) => m (a, s, w) -> 'RWST' r w s m a + -- @ + restoreT :: Monad m => m (StT t a) -> t m a + +-- | A function that runs a transformed monad @t n@ on the monadic state that +-- was captured by 'liftWith' +-- +-- A @Run t@ function yields a computation in @n@ that returns the monadic state +-- of @t@. This state can later be used to restore a @t@ computation using +-- 'restoreT'. +-- +-- Example type equalities: +-- +-- @ +-- Run 'IdentityT' ~ forall n b. 'Monad' n => 'IdentityT' n b -> n b +-- Run 'MaybeT' ~ forall n b. 'Monad' n => 'MaybeT' n b -> n ('Maybe' b) +-- Run ('ErrorT' e) ~ forall n b. ('Monad' n, 'Error' e) => 'ErrorT' e n b -> n ('Either' e b) +-- Run ('ExceptT' e) ~ forall n b. 'Monad' n => 'ExceptT' e n b -> n ('Either' e b) +-- Run 'ListT' ~ forall n b. 'Monad' n => 'ListT' n b -> n [b] +-- Run ('ReaderT' r) ~ forall n b. 'Monad' n => 'ReaderT' r n b -> n b +-- Run ('StateT' s) ~ forall n b. 'Monad' n => 'StateT' s n b -> n (a, s) +-- Run ('WriterT' w) ~ forall n b. ('Monad' n, 'Monoid' w) => 'WriterT' w n b -> n (a, w) +-- Run ('RWST' r w s) ~ forall n b. ('Monad' n, 'Monoid' w) => 'RWST' r w s n b -> n (a, s, w) +-- @ +-- +-- This type is usually satisfied by the @run@ function of a transformer: +-- +-- @ +-- 'flip' 'runReaderT' :: r -> Run ('ReaderT' r) +-- 'flip' 'runStateT' :: s -> Run ('StateT' s) +-- 'runMaybeT' :: Run 'MaybeT' +-- @ +type Run t = forall n b. Monad n => t n b -> n (StT t b) + + +-------------------------------------------------------------------------------- +-- Defaults for MonadTransControl +-------------------------------------------------------------------------------- + +-- $MonadTransControlDefaults +-- +-- The following functions can be used to define a 'MonadTransControl' instance +-- for a monad transformer which simply is a newtype around another monad +-- transformer which already has a @MonadTransControl@ instance. For example: +-- +-- @ +-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} +-- {-\# LANGUAGE UndecidableInstances \#-} +-- {-\# LANGUAGE TypeFamilies \#-} +-- +-- newtype CounterT m a = CounterT {unCounterT :: StateT Int m a} +-- deriving (Monad, MonadTrans) +-- +-- instance MonadTransControl CounterT where +-- type StT CounterT a = StT (StateT Int) a +-- liftWith = 'defaultLiftWith' CounterT unCounterT +-- restoreT = 'defaultRestoreT' CounterT +-- @ + +-- | A function like 'Run' that runs a monad transformer @t@ which wraps the +-- monad transformer @t'@. This is used in 'defaultLiftWith'. +type RunDefault t t' = forall n b. Monad n => t n b -> n (StT t' b) + +-- | Default definition for the 'liftWith' method. +defaultLiftWith :: (Monad m, MonadTransControl n) + => (forall b. n m b -> t m b) -- ^ Monad constructor + -> (forall o b. t o b -> n o b) -- ^ Monad deconstructor + -> (RunDefault t n -> m a) + -> t m a +defaultLiftWith t unT = \f -> t $ liftWith $ \run -> f $ run . unT +{-# INLINABLE defaultLiftWith #-} + +-- | Default definition for the 'restoreT' method. +defaultRestoreT :: (Monad m, MonadTransControl n) + => (n m a -> t m a) -- ^ Monad constructor + -> m (StT n a) + -> t m a +defaultRestoreT t = t . restoreT +{-# INLINABLE defaultRestoreT #-} + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +-- $MonadTransControlDefaults2 +-- +-- The following functions can be used to define a 'MonadTransControl' instance +-- for a monad transformer stack of two. +-- +-- @ +-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} +-- +-- newtype CalcT m a = CalcT { unCalcT :: StateT Int (ExceptT String m) a } +-- deriving (Monad, MonadTrans) +-- +-- instance MonadTransControl CalcT where +-- type StT CalcT a = StT (ExceptT String) (StT (StateT Int) a) +-- liftWith = 'defaultLiftWith2' CalcT unCalcT +-- restoreT = 'defaultRestoreT2' CalcT +-- @ + +-- | A function like 'Run' that runs a monad transformer @t@ which wraps the +-- monad transformers @n@ and @n'@. This is used in 'defaultLiftWith2'. +type RunDefault2 t n n' = forall m b. (Monad m, Monad (n' m)) => t m b -> m (StT n' (StT n b)) + +-- | Default definition for the 'liftWith' method. +defaultLiftWith2 :: (Monad m, Monad (n' m), MonadTransControl n, MonadTransControl n') + => (forall b. n (n' m) b -> t m b) -- ^ Monad constructor + -> (forall o b. t o b -> n (n' o) b) -- ^ Monad deconstructor + -> (RunDefault2 t n n' -> m a) + -> t m a +defaultLiftWith2 t unT = \f -> t $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unT +{-# INLINABLE defaultLiftWith2 #-} + +-- | Default definition for the 'restoreT' method for double 'MonadTransControl'. +defaultRestoreT2 :: (Monad m, Monad (n' m), MonadTransControl n, MonadTransControl n') + => (n (n' m) a -> t m a) -- ^ Monad constructor + -> m (StT n' (StT n a)) + -> t m a +defaultRestoreT2 t = t . restoreT . restoreT +{-# INLINABLE defaultRestoreT2 #-} + +-------------------------------------------------------------------------------- +-- MonadTransControl instances +-------------------------------------------------------------------------------- + +instance MonadTransControl IdentityT where + type StT IdentityT a = a + liftWith f = IdentityT $ f $ runIdentityT + restoreT = IdentityT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl MaybeT where + type StT MaybeT a = Maybe a + liftWith f = MaybeT $ liftM return $ f $ runMaybeT + restoreT = MaybeT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +#if !(MIN_VERSION_transformers(0,6,0)) +instance MonadTransControl ListT where + type StT ListT a = [a] + liftWith f = ListT $ liftM return $ f $ runListT + restoreT = ListT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Error e => MonadTransControl (ErrorT e) where + type StT (ErrorT e) a = Either e a + liftWith f = ErrorT $ liftM return $ f $ runErrorT + restoreT = ErrorT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} +#endif + +instance MonadTransControl (ExceptT e) where + type StT (ExceptT e) a = Either e a + liftWith f = ExceptT $ liftM return $ f $ runExceptT + restoreT = ExceptT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl (ReaderT r) where + type StT (ReaderT r) a = a + liftWith f = ReaderT $ \r -> f $ \t -> runReaderT t r + restoreT = ReaderT . const + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl (StateT s) where + type StT (StateT s) a = (a, s) + liftWith f = StateT $ \s -> + liftM (\x -> (x, s)) + (f $ \t -> runStateT t s) + restoreT = StateT . const + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl (Strict.StateT s) where + type StT (Strict.StateT s) a = (a, s) + liftWith f = Strict.StateT $ \s -> + liftM (\x -> (x, s)) + (f $ \t -> Strict.runStateT t s) + restoreT = Strict.StateT . const + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (WriterT w) where + type StT (WriterT w) a = (a, w) + liftWith f = WriterT $ liftM (\x -> (x, mempty)) + (f $ runWriterT) + restoreT = WriterT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (Strict.WriterT w) where + type StT (Strict.WriterT w) a = (a, w) + liftWith f = Strict.WriterT $ liftM (\x -> (x, mempty)) + (f $ Strict.runWriterT) + restoreT = Strict.WriterT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (RWST r w s) where + type StT (RWST r w s) a = (a, s, w) + liftWith f = RWST $ \r s -> liftM (\x -> (x, s, mempty)) + (f $ \t -> runRWST t r s) + restoreT mSt = RWST $ \_ _ -> mSt + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (Strict.RWST r w s) where + type StT (Strict.RWST r w s) a = (a, s, w) + liftWith f = + Strict.RWST $ \r s -> liftM (\x -> (x, s, mempty)) + (f $ \t -> Strict.runRWST t r s) + restoreT mSt = Strict.RWST $ \_ _ -> mSt + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + + +-------------------------------------------------------------------------------- +-- MonadBaseControl type class +-------------------------------------------------------------------------------- + +-- | +-- == Writing instances +-- +-- The usual way to write a @'MonadBaseControl'@ instance for a transformer +-- stack over a base monad @B@ is to write an instance @MonadBaseControl B B@ +-- for the base monad, and @MonadTransControl T@ instances for every transformer +-- @T@. Instances for @'MonadBaseControl'@ are then simply implemented using +-- @'ComposeSt'@, @'defaultLiftBaseWith'@, @'defaultRestoreM'@. +class MonadBase b m => MonadBaseControl b m | m -> b where + -- | Monadic state that @m@ adds to the base monad @b@. + -- + -- For all base (non-transformed) monads, @StM m a ~ a@: + -- + -- @ + -- StM 'IO' a ~ a + -- StM 'Maybe' a ~ a + -- StM ('Either' e) a ~ a + -- StM [] a ~ a + -- StM ((->) r) a ~ a + -- StM 'Identity' a ~ a + -- StM 'STM' a ~ a + -- StM ('ST' s) a ~ a + -- @ + -- + -- If @m@ is a transformed monad, @m ~ t b@, @'StM'@ is the monadic state of + -- the transformer @t@ (given by its 'StT' from 'MonadTransControl'). For a + -- transformer stack, @'StM'@ is defined recursively: + -- + -- @ + -- StM ('IdentityT' m) a ~ 'ComposeSt' 'IdentityT' m a ~ StM m a + -- StM ('MaybeT' m) a ~ 'ComposeSt' 'MaybeT' m a ~ StM m ('Maybe' a) + -- StM ('ErrorT' e m) a ~ 'ComposeSt' 'ErrorT' m a ~ 'Error' e => StM m ('Either' e a) + -- StM ('ExceptT' e m) a ~ 'ComposeSt' 'ExceptT' m a ~ StM m ('Either' e a) + -- StM ('ListT' m) a ~ 'ComposeSt' 'ListT' m a ~ StM m [a] + -- StM ('ReaderT' r m) a ~ 'ComposeSt' 'ReaderT' m a ~ StM m a + -- StM ('StateT' s m) a ~ 'ComposeSt' 'StateT' m a ~ StM m (a, s) + -- StM ('WriterT' w m) a ~ 'ComposeSt' 'WriterT' m a ~ 'Monoid' w => StM m (a, w) + -- StM ('RWST' r w s m) a ~ 'ComposeSt' 'RWST' m a ~ 'Monoid' w => StM m (a, s, w) + -- @ + type StM m a :: * + + -- | @liftBaseWith@ is similar to 'liftIO' and 'liftBase' in that it + -- lifts a base computation to the constructed monad. + -- + -- Instances should satisfy similar laws as the 'MonadIO' and 'MonadBase' laws: + -- + -- @liftBaseWith (\\_ -> return a) = return a@ + -- + -- @liftBaseWith (\\_ -> m >>= f) = liftBaseWith (\\_ -> m) >>= (\\a -> liftBaseWith (\\_ -> f a))@ + -- + -- As , parametricity + -- guarantees that + -- + -- @f <$> liftBaseWith q = liftBaseWith $ \runInBase -> f <$> q runInBase@ + -- + -- The difference with 'liftBase' is that before lifting the base computation + -- @liftBaseWith@ captures the state of @m@. It then provides the base + -- computation with a 'RunInBase' function that allows running @m@ + -- computations in the base monad on the captured state: + -- + -- @ + -- withFileLifted :: MonadBaseControl IO m => FilePath -> IOMode -> (Handle -> m a) -> m a + -- withFileLifted file mode action = liftBaseWith (\\runInBase -> withFile file mode (runInBase . action)) >>= restoreM + -- -- = control $ \\runInBase -> withFile file mode (runInBase . action) + -- -- = liftBaseOp (withFile file mode) action + -- @ + -- + -- @'liftBaseWith'@ is usually not implemented directly, but using + -- @'defaultLiftBaseWith'@. + liftBaseWith :: (RunInBase m b -> b a) -> m a + + -- | Construct a @m@ computation from the monadic state of @m@ that is + -- returned from a 'RunInBase' function. + -- + -- Instances should satisfy: + -- + -- @liftBaseWith (\\runInBase -> runInBase m) >>= restoreM = m@ + -- + -- @'restoreM'@ is usually not implemented directly, but using + -- @'defaultRestoreM'@. + restoreM :: StM m a -> m a + +-- | A function that runs a @m@ computation on the monadic state that was +-- captured by 'liftBaseWith' +-- +-- A @RunInBase m@ function yields a computation in the base monad of @m@ that +-- returns the monadic state of @m@. This state can later be used to restore the +-- @m@ computation using 'restoreM'. +-- +-- Example type equalities: +-- +-- @ +-- RunInBase ('IdentityT' m) b ~ forall a. 'IdentityT' m a -> b ('StM' m a) +-- RunInBase ('MaybeT' m) b ~ forall a. 'MaybeT' m a -> b ('StM' m ('Maybe' a)) +-- RunInBase ('ErrorT' e m) b ~ forall a. 'Error' e => 'ErrorT' e m a -> b ('StM' m ('Either' e a)) +-- RunInBase ('ExceptT' e m) b ~ forall a. 'ExceptT' e m a -> b ('StM' m ('Either' e a)) +-- RunInBase ('ListT' m) b ~ forall a. 'ListT' m a -> b ('StM' m [a]) +-- RunInBase ('ReaderT' r m) b ~ forall a. 'ReaderT' m a -> b ('StM' m a) +-- RunInBase ('StateT' s m) b ~ forall a. 'StateT' s m a -> b ('StM' m (a, s)) +-- RunInBase ('WriterT' w m) b ~ forall a. 'Monoid' w => 'WriterT' w m a -> b ('StM' m (a, w)) +-- RunInBase ('RWST' r w s m) b ~ forall a. 'Monoid' w => 'RWST' r w s m a -> b ('StM' m (a, s, w)) +-- @ +-- +-- For a transformed base monad @m ~ t b@, @'RunInBase m b' ~ 'Run' t@. +type RunInBase m b = forall a. m a -> b (StM m a) + + +-------------------------------------------------------------------------------- +-- MonadBaseControl instances for all monads in the base library +-------------------------------------------------------------------------------- + +#define BASE(M) \ +instance MonadBaseControl (M) (M) where { \ + type StM (M) a = a; \ + liftBaseWith f = f id; \ + restoreM = return; \ + {-# INLINABLE liftBaseWith #-}; \ + {-# INLINABLE restoreM #-}} + +BASE(IO) +BASE(Maybe) +BASE(Either e) +BASE([]) +BASE((->) r) +BASE(Identity) + +BASE(STM) + +BASE(Strict.ST s) +BASE( ST s) + +#undef BASE + + +-------------------------------------------------------------------------------- +-- Defaults for MonadBaseControl +-------------------------------------------------------------------------------- + +-- $MonadBaseControlDefaults +-- +-- Note that by using the following default definitions it's easy to make a +-- monad transformer @T@ an instance of 'MonadBaseControl': +-- +-- @ +-- instance MonadBaseControl b m => MonadBaseControl b (T m) where +-- type StM (T m) a = 'ComposeSt' T m a +-- liftBaseWith = 'defaultLiftBaseWith' +-- restoreM = 'defaultRestoreM' +-- @ +-- +-- Defining an instance for a base monad @B@ is equally straightforward: +-- +-- @ +-- instance MonadBaseControl B B where +-- type StM B a = a +-- liftBaseWith f = f 'id' +-- restoreM = 'return' +-- @ + +-- | Handy type synonym that composes the monadic states of @t@ and @m@. +-- +-- It can be used to define the 'StM' for new 'MonadBaseControl' instances. +type ComposeSt t m a = StM m (StT t a) + +-- | A function like 'RunInBase' that runs a monad transformer @t@ in its base +-- monad @b@. It is used in 'defaultLiftBaseWith'. +type RunInBaseDefault t m b = forall a. t m a -> b (ComposeSt t m a) + +-- | Default definition for the 'liftBaseWith' method. +-- +-- Note that it composes a 'liftWith' of @t@ with a 'liftBaseWith' of @m@ to +-- give a 'liftBaseWith' of @t m@: +-- +-- @ +-- defaultLiftBaseWith = \\f -> 'liftWith' $ \\run -> +-- 'liftBaseWith' $ \\runInBase -> +-- f $ runInBase . run +-- @ +defaultLiftBaseWith :: (MonadTransControl t, MonadBaseControl b m) + => (RunInBaseDefault t m b -> b a) -> t m a +defaultLiftBaseWith = \f -> liftWith $ \run -> + liftBaseWith $ \runInBase -> + f $ runInBase . run +{-# INLINABLE defaultLiftBaseWith #-} + +-- | Default definition for the 'restoreM' method. +-- +-- Note that: @defaultRestoreM = 'restoreT' . 'restoreM'@ +defaultRestoreM :: (MonadTransControl t, MonadBaseControl b m) + => ComposeSt t m a -> t m a +defaultRestoreM = restoreT . restoreM +{-# INLINABLE defaultRestoreM #-} + + +-------------------------------------------------------------------------------- +-- MonadBaseControl transformer instances +-------------------------------------------------------------------------------- + +#define BODY(T) { \ + type StM (T m) a = ComposeSt (T) m a; \ + liftBaseWith = defaultLiftBaseWith; \ + restoreM = defaultRestoreM; \ + {-# INLINABLE liftBaseWith #-}; \ + {-# INLINABLE restoreM #-}} + +#define TRANS( T) \ + instance ( MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T) +#define TRANS_CTX(CTX, T) \ + instance (CTX, MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T) + +TRANS(IdentityT) +TRANS(MaybeT) +TRANS(ReaderT r) +TRANS(Strict.StateT s) +TRANS( StateT s) +TRANS(ExceptT e) + +TRANS_CTX(Monoid w, Strict.WriterT w) +TRANS_CTX(Monoid w, WriterT w) +TRANS_CTX(Monoid w, Strict.RWST r w s) +TRANS_CTX(Monoid w, RWST r w s) + +#if !(MIN_VERSION_transformers(0,6,0)) +TRANS(ListT) +TRANS_CTX(Error e, ErrorT e) +#endif + +#undef BODY +#undef TRANS +#undef TRANS_CTX + +-------------------------------------------------------------------------------- +-- * Utility functions +-------------------------------------------------------------------------------- + +-- | An often used composition: @control f = 'liftBaseWith' f >>= 'restoreM'@ +-- +-- Example: +-- +-- @ +-- liftedBracket :: MonadBaseControl IO m => m a -> (a -> m b) -> (a -> m c) -> m c +-- liftedBracket acquire release action = control $ \\runInBase -> +-- bracket (runInBase acquire) +-- (\\saved -> runInBase (restoreM saved >>= release)) +-- (\\saved -> runInBase (restoreM saved >>= action)) +-- @ +control :: MonadBaseControl b m => (RunInBase m b -> b (StM m a)) -> m a +control f = liftBaseWith f >>= restoreM +{-# INLINABLE control #-} + +-- | Lift a computation and restore the monadic state immediately: +-- @controlT f = 'liftWith' f >>= 'restoreT' . return@. +controlT :: (MonadTransControl t, Monad (t m), Monad m) + => (Run t -> m (StT t a)) -> t m a +controlT f = liftWith f >>= restoreT . return +{-# INLINABLE controlT #-} + +-- | Embed a transformer function as an function in the base monad returning a +-- mutated transformer state. +embed :: MonadBaseControl b m => (a -> m c) -> m (a -> b (StM m c)) +embed f = liftBaseWith $ \runInBase -> return (runInBase . f) +{-# INLINABLE embed #-} + +-- | Performs the same function as 'embed', but discards transformer state +-- from the embedded function. +embed_ :: MonadBaseControl b m => (a -> m ()) -> m (a -> b ()) +embed_ f = liftBaseWith $ \runInBase -> return (void . runInBase . f) +{-# INLINABLE embed_ #-} + +-- | Capture the current state of a transformer +captureT :: (MonadTransControl t, Monad (t m), Monad m) => t m (StT t ()) +captureT = liftWith $ \runInM -> runInM (return ()) +{-# INLINABLE captureT #-} + +-- | Capture the current state above the base monad +captureM :: MonadBaseControl b m => m (StM m ()) +captureM = liftBaseWith $ \runInBase -> runInBase (return ()) +{-# INLINABLE captureM #-} + +-- | @liftBaseOp@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @((a -> b c) -> b c)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => (a -> m c) -> m c)@ +-- +-- For example: +-- +-- @liftBaseOp alloca :: (Storable a, 'MonadBaseControl' 'IO' m) => (Ptr a -> m c) -> m c@ +liftBaseOp :: MonadBaseControl b m + => ((a -> b (StM m c)) -> b (StM m d)) + -> ((a -> m c) -> m d) +liftBaseOp f = \g -> control $ \runInBase -> f $ runInBase . g +{-# INLINABLE liftBaseOp #-} + +-- | @liftBaseOp_@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @(b a -> b a)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => m a -> m a)@ +-- +-- For example: +-- +-- @liftBaseOp_ mask_ :: 'MonadBaseControl' 'IO' m => m a -> m a@ +liftBaseOp_ :: MonadBaseControl b m + => (b (StM m a) -> b (StM m c)) + -> ( m a -> m c) +liftBaseOp_ f = \m -> control $ \runInBase -> f $ runInBase m +{-# INLINABLE liftBaseOp_ #-} + +-- | @liftBaseDiscard@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @(b () -> b a)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => m () -> m a)@ +-- +-- Note that, while the argument computation @m ()@ has access to the captured +-- state, all its side-effects in @m@ are discarded. It is run only for its +-- side-effects in the base monad @b@. +-- +-- For example: +-- +-- @liftBaseDiscard forkIO :: 'MonadBaseControl' 'IO' m => m () -> m ThreadId@ +liftBaseDiscard :: MonadBaseControl b m => (b () -> b a) -> (m () -> m a) +liftBaseDiscard f = \m -> liftBaseWith $ \runInBase -> f $ void $ runInBase m +{-# INLINABLE liftBaseDiscard #-} + +-- | @liftBaseOpDiscard@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @((a -> b ()) -> b c)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => (a -> m ()) -> m c)@ +-- +-- Note that, while the argument computation @m ()@ has access to the captured +-- state, all its side-effects in @m@ are discarded. It is run only for its +-- side-effects in the base monad @b@. +-- +-- For example: +-- +-- @liftBaseDiscard (runServer addr port) :: 'MonadBaseControl' 'IO' m => m () -> m ()@ +liftBaseOpDiscard :: MonadBaseControl b m + => ((a -> b ()) -> b c) + -> (a -> m ()) -> m c +liftBaseOpDiscard f g = liftBaseWith $ \runInBase -> f $ void . runInBase . g +{-# INLINABLE liftBaseOpDiscard #-} + +-- | Transform an action in @t m@ using a transformer that operates on the underlying monad @m@ +liftThrough + :: (MonadTransControl t, Monad (t m), Monad m) + => (m (StT t a) -> m (StT t b)) -- ^ + -> t m a -> t m b +liftThrough f t = do + st <- liftWith $ \run -> do + f $ run t + restoreT $ return st diff --git a/test.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- from base: -import Prelude hiding (catch) -import Data.IORef -import Data.Maybe -import Data.Typeable (Typeable) - --- from transformers: -import Control.Monad.IO.Class (liftIO) - -import Control.Monad.Trans.Identity -import Control.Monad.Trans.List -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Error -import Control.Monad.Trans.State -import qualified Control.Monad.Trans.RWS as RWS - --- from monad-control (this package): -import Control.Exception.Control -import Control.Monad.IO.Control (MonadControlIO) - --- from test-framework: -import Test.Framework (defaultMain, testGroup, Test) - - -- from test-framework-hunit: -import Test.Framework.Providers.HUnit - --- from hunit: -import Test.HUnit hiding (Test) - - -main :: IO () -main = defaultMain - [ testSuite "IdentityT" runIdentityT - , testSuite "ListT" $ fmap head . runListT - , testSuite "MaybeT" $ fmap fromJust . runMaybeT - , testSuite "ReaderT" $ flip runReaderT "reader state" - , testSuite "WriterT" runWriterT' - , testSuite "ErrorT" runErrorT' - , testSuite "StateT" $ flip evalStateT "state state" - , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state" - , testCase "ErrorT throwError" case_throwError - , testCase "WriterT tell" case_tell - ] - where - runWriterT' :: Functor m => WriterT [Int] m a -> m a - runWriterT' = fmap fst . runWriterT - runErrorT' :: Functor m => ErrorT String m () -> m () - runErrorT' = fmap (either (const ()) id) . runErrorT - runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a - runRWST' m r s = fmap fst $ RWS.evalRWST m r s - -testSuite :: MonadControlIO m => String -> (m () -> IO ()) -> Test -testSuite s run = testGroup s - [ testCase "finally" $ case_finally run - , testCase "catch" $ case_catch run - , testCase "bracket" $ case_bracket run - , testCase "bracket_" $ case_bracket_ run - , testCase "onException" $ case_onException run - ] - -ignore :: IO () -> IO () -ignore x = - catch x go - where - go :: SomeException -> IO () - go _ = return () - -data Exc = Exc - deriving (Show, Typeable) -instance Exception Exc - -one :: Int -one = 1 - -case_finally :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_finally run = do - i <- newIORef one - ignore - (run $ (do - liftIO $ writeIORef i 2 - error "error") `finally` (liftIO $ writeIORef i 3)) - j <- readIORef i - j @?= 3 - -case_catch :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_catch run = do - i <- newIORef one - run $ (do - liftIO $ writeIORef i 2 - throw Exc) `catch` (\Exc -> liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 3 - -case_bracket :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_bracket run = do - i <- newIORef one - ignore $ run $ bracket - (liftIO $ writeIORef i 2) - (\() -> liftIO $ writeIORef i 4) - (\() -> liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 4 - -case_bracket_ :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_bracket_ run = do - i <- newIORef one - ignore $ run $ bracket_ - (liftIO $ writeIORef i 2) - (liftIO $ writeIORef i 4) - (liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 4 - -case_onException :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_onException run = do - i <- newIORef one - ignore $ run $ onException - (liftIO (writeIORef i 2) >> error "ignored") - (liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 3 - ignore $ run $ onException - (liftIO $ writeIORef i 4) - (liftIO $ writeIORef i 5) - k <- readIORef i - k @?= 4 - -case_throwError :: Assertion -case_throwError = do - i <- newIORef one - Left "throwError" <- runErrorT $ - (liftIO (writeIORef i 2) >> throwError "throwError") - `finally` - (liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 3 - -case_tell :: Assertion -case_tell = do - i <- newIORef one - ((), w) <- runWriterT $ bracket_ - (liftIO (writeIORef i 2) >> tell [1 :: Int]) - (liftIO (writeIORef i 4) >> tell [3]) - (liftIO (writeIORef i 3) >> tell [2]) - j <- readIORef i - j @?= 4 - w @?= [2] - - ((), w') <- runWriterT $ bracket - (liftIO (writeIORef i 5) >> tell [5 :: Int]) - (const $ liftIO (writeIORef i 7) >> tell [7]) - (const $ liftIO (writeIORef i 6) >> tell [6]) - j' <- readIORef i - j' @?= 7 - w' @?= [5, 6]