monad-control 0.2.0.3 → 1.0.3.1
raw patch · 10 files changed
Files
- CHANGELOG +506/−0
- Control/Exception/Control.hs +0/−362
- Control/Monad/IO/Control.hs +0/−180
- Control/Monad/Trans/Control.hs +0/−275
- NEWS +0/−334
- README.markdown +5/−7
- Setup.hs +0/−44
- monad-control.cabal +57/−63
- src/Control/Monad/Trans/Control.hs +872/−0
- test.hs +0/−159
+ CHANGELOG view
@@ -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
− Control/Exception/Control.hs
@@ -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 <v.dijk.bas@gmail.com>-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 ---------------------------------------------------------------------
− Control/Monad/IO/Control.hs
@@ -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 <v.dijk.bas@gmail.com>-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 ---------------------------------------------------------------------
− Control/Monad/Trans/Control.hs
@@ -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 <v.dijk.bas@gmail.com>-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 ---------------------------------------------------------------------
− NEWS
@@ -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
README.markdown view
@@ -1,19 +1,17 @@+[](https://hackage.haskell.org/package/monad-control)+[](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`.
− Setup.hs
@@ -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 ---------------------------------------------------------------------
monad-control.cabal view
@@ -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 <oleg.grenrus@iki.fi>, Bas van Dijk <v.dijk.bas@gmail.com>++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 <http://hackage.haskell.org/package/lifted-base lifted-base>+ 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@. .- <https://github.com/basvandijk/bench-monad-peel-control>--License: BSD3-License-file: LICENSE-Author: Bas van Dijk, Anders Kaseorg-Maintainer: Bas van Dijk <v.dijk.bas@gmail.com>-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
+ src/Control/Monad/Trans/Control.hs view
@@ -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 <v.dijk.bas@gmail.com>++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 <http://hackage.haskell.org/package/lifted-base lifted-base>+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:++<https://www.yesodweb.com/book/monad-control>++=== 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 <https://stackoverflow.com/a/58106822/1477667 Li-yao Xia explains>, 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
− test.hs
@@ -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]