diff --git a/Control/Exception/Control.hs b/Control/Exception/Control.hs deleted file mode 100644 --- a/Control/Exception/Control.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, ExistentialQuantification #-} - -#if MIN_VERSION_base(4,3,0) -{-# LANGUAGE RankNTypes #-} -- for mask -#endif - -{- | -Module : Control.Exception.Control -Copyright : Bas van Dijk, Anders Kaseorg -License : BSD-style - -Maintainer : Bas van Dijk -Stability : experimental -Portability : non-portable (extended exceptions) - -This is a wrapped version of @Control.Exception@ with types generalized -from @IO@ to all monads in 'MonadControlIO'. --} - -module Control.Exception.Control - ( module Control.Exception - - -- * Throwing exceptions - , throwIO, ioError - - -- * Catching exceptions - -- ** The @catch@ functions - , catch, catches, Handler(..), catchJust - - -- ** The @handle@ functions - , handle, handleJust - - -- ** The @try@ functions - , try, tryJust - - -- ** The @evaluate@ function - , evaluate - - -- * Asynchronous Exceptions - -- ** Asynchronous exception control - -- |The following functions allow a thread to control delivery of - -- asynchronous exceptions during a critical region. -#if MIN_VERSION_base(4,3,0) - , mask, mask_ - , uninterruptibleMask, uninterruptibleMask_ - , getMaskingState -#else - , block, unblock -#endif - -#if !MIN_VERSION_base(4,4,0) - , blocked -#endif - -- * Brackets - , bracket, bracket_, bracketOnError - - -- * Utilities - , finally, onException - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Data.Function ( ($) ) -import Data.Either ( Either(Left, Right), either ) -import Data.Maybe ( Maybe ) -import Control.Monad ( Monad, (>>=), return, liftM ) -import System.IO.Error ( IOError ) - -#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__) -import System.IO ( IO ) -#endif - -#if __GLASGOW_HASKELL__ < 700 -import Control.Monad ( fail ) -#endif - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from transformers: -import Control.Monad.IO.Class ( MonadIO, liftIO ) - -import Control.Exception hiding - ( throwIO, ioError - , catch, catches, Handler(..), catchJust - , handle, handleJust - , try, tryJust - , evaluate -#if MIN_VERSION_base(4,3,0) - , mask, mask_ - , uninterruptibleMask, uninterruptibleMask_ - , getMaskingState -#else - , block, unblock -#endif -#if !MIN_VERSION_base(4,4,0) - , blocked -#endif - , bracket, bracket_, bracketOnError - , finally, onException - ) -import qualified Control.Exception as E - -#if !MIN_VERSION_base(4,4,0) -import Data.Bool ( Bool ) -#endif - --- from monad-control (this package): -import Control.Monad.IO.Control ( MonadControlIO - , controlIO - , liftIOOp_ - ) -#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__) -import Control.Monad.IO.Control ( liftIOOp ) -#endif - --------------------------------------------------------------------------------- --- * Throwing exceptions --------------------------------------------------------------------------------- - --- |Generalized version of 'E.throwIO'. -throwIO ∷ (MonadIO m, Exception e) ⇒ e → m α -throwIO = liftIO ∘ E.throwIO - --- |Generalized version of 'E.ioError'. -ioError ∷ MonadIO m ⇒ IOError → m α -ioError = liftIO ∘ E.ioError - - --------------------------------------------------------------------------------- --- * Catching exceptions --------------------------------------------------------------------------------- - --- |Generalized version of 'E.catch'. -{-# INLINABLE catch #-} -catch ∷ (MonadControlIO m, Exception e) - ⇒ m α -- ^ The computation to run - → (e → m α) -- ^ Handler to invoke if an exception is raised - → m α -catch a handler = controlIO $ \runInIO → - E.catch (runInIO a) - (\e → runInIO $ handler e) - --- |Generalized version of 'E.catches'. -{-# INLINABLE catches #-} -catches ∷ MonadControlIO m ⇒ m α → [Handler m α] → m α -catches a handlers = controlIO $ \runInIO → - E.catches (runInIO a) - [ E.Handler $ \e → runInIO $ handler e - | Handler handler ← handlers - ] - --- |Generalized version of 'E.Handler'. -data Handler m α = ∀ e. Exception e ⇒ Handler (e → m α) - --- |Generalized version of 'E.catchJust'. -{-# INLINABLE catchJust #-} -catchJust ∷ (MonadControlIO m, Exception e) - ⇒ (e → Maybe β) -- ^ Predicate to select exceptions - → m α -- ^ Computation to run - → (β → m α) -- ^ Handler - → m α -catchJust p a handler = controlIO $ \runInIO → - E.catchJust p - (runInIO a) - (\e → runInIO (handler e)) - - --------------------------------------------------------------------------------- --- ** The @handle@ functions --------------------------------------------------------------------------------- - --- |Generalized version of 'E.handle'. -{-# INLINABLE handle #-} -handle ∷ (MonadControlIO m, Exception e) ⇒ (e → m α) → m α → m α -handle handler a = controlIO $ \runInIO → - E.handle (\e → runInIO (handler e)) - (runInIO a) - --- |Generalized version of 'E.handleJust'. -{-# INLINABLE handleJust #-} -handleJust ∷ (MonadControlIO m, Exception e) - ⇒ (e → Maybe β) → (β → m α) → m α → m α -handleJust p handler a = controlIO $ \runInIO → - E.handleJust p (\e → runInIO (handler e)) - (runInIO a) - - --------------------------------------------------------------------------------- --- ** The @try@ functions --------------------------------------------------------------------------------- - -sequenceEither ∷ Monad m ⇒ Either e (m α) → m (Either e α) -sequenceEither = either (return ∘ Left) (liftM Right) - --- |Generalized version of 'E.try'. -{-# INLINABLE try #-} -try ∷ (MonadControlIO m, Exception e) ⇒ m α → m (Either e α) -try = liftIOOp_ (liftM sequenceEither ∘ E.try) - --- |Generalized version of 'E.tryJust'. -{-# INLINABLE tryJust #-} -tryJust ∷ (MonadControlIO m, Exception e) ⇒ - (e → Maybe β) → m α → m (Either β α) -tryJust p = liftIOOp_ (liftM sequenceEither ∘ E.tryJust p) - - --------------------------------------------------------------------------------- --- ** The @evaluate@ function --------------------------------------------------------------------------------- - --- |Generalized version of 'E.evaluate'. -evaluate ∷ MonadIO m ⇒ α → m α -evaluate = liftIO ∘ E.evaluate - - --------------------------------------------------------------------------------- --- ** Asynchronous exception control --------------------------------------------------------------------------------- - -#if MIN_VERSION_base(4,3,0) --- |Generalized version of 'E.mask'. -{-# INLINABLE mask #-} -mask ∷ MonadControlIO m ⇒ ((∀ α. m α → m α) → m β) → m β -mask = liftIOOp E.mask ∘ liftRestore - -liftRestore ∷ MonadControlIO m - ⇒ ((∀ α. m α → m α) → β) - → ((∀ α. IO α → IO α) → β) -liftRestore f restore = f $ liftIOOp_ restore - --- |Generalized version of 'E.mask_'. -{-# INLINABLE mask_ #-} -mask_ ∷ MonadControlIO m ⇒ m α → m α -mask_ = liftIOOp_ E.mask_ - --- |Generalized version of 'E.uninterruptibleMask'. -{-# INLINABLE uninterruptibleMask #-} -uninterruptibleMask ∷ MonadControlIO m ⇒ ((∀ α. m α → m α) → m β) → m β -uninterruptibleMask = liftIOOp E.uninterruptibleMask ∘ liftRestore - --- |Generalized version of 'E.uninterruptibleMask_'. -{-# INLINABLE uninterruptibleMask_ #-} -uninterruptibleMask_ ∷ MonadControlIO m ⇒ m α → m α -uninterruptibleMask_ = liftIOOp_ E.uninterruptibleMask_ - --- |Generalized version of 'E.getMaskingState'. -getMaskingState ∷ MonadIO m ⇒ m MaskingState -getMaskingState = liftIO E.getMaskingState -#else --- |Generalized version of 'E.block'. -{-# INLINABLE block #-} -block ∷ MonadControlIO m ⇒ m α → m α -block = liftIOOp_ E.block - --- |Generalized version of 'E.unblock'. -{-# INLINABLE unblock #-} -unblock ∷ MonadControlIO m ⇒ m α → m α -unblock = liftIOOp_ E.unblock -#endif - -#if !MIN_VERSION_base(4,4,0) --- | Generalized version of 'E.blocked'. --- returns @True@ if asynchronous exceptions are blocked in the --- current thread. -blocked ∷ MonadIO m ⇒ m Bool -blocked = liftIO E.blocked -#endif - - --------------------------------------------------------------------------------- --- * Brackets --------------------------------------------------------------------------------- - --- |Generalized version of 'E.bracket'. Note, any monadic side --- effects in @m@ of the \"release\" computation will be discarded; it --- is run only for its side effects in @IO@. --- --- Note that when your @acquire@ and @release@ computations are of type 'IO' --- it will be more efficient to write: --- --- @'liftIOOp' ('E.bracket' acquire release)@ -{-# INLINABLE bracket #-} -bracket ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first (\"acquire resource\") - → (α → m β) -- ^ computation to run last (\"release resource\") - → (α → m γ) -- ^ computation to run in-between - → m γ -bracket before after thing = controlIO $ \runInIO → - E.bracket (runInIO before) - (\m → runInIO $ m >>= after) - (\m → runInIO $ m >>= thing) - --- |Generalized version of 'E.bracket_'. Note, any monadic side --- effects in @m@ of /both/ the \"acquire\" and \"release\" --- computations will be discarded. To keep the monadic side effects --- of the \"acquire\" computation, use 'bracket' with constant --- functions instead. --- --- Note that when your @acquire@ and @release@ computations are of type 'IO' --- it will be more efficient to write: --- --- @'liftIOOp_' ('E.bracket_' acquire release)@ -{-# INLINABLE bracket_ #-} -bracket_ ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first (\"acquire resource\") - → m β -- ^ computation to run last (\"release resource\") - → m γ -- ^ computation to run in-between - → m γ -bracket_ before after thing = controlIO $ \runInIO → - E.bracket_ (runInIO before) - (runInIO after) - (runInIO thing) - --- |Generalized version of 'E.bracketOnError'. Note, any monadic side --- effects in @m@ of the \"release\" computation will be discarded. --- --- Note that when your @acquire@ and @release@ computations are of type 'IO' --- it will be more efficient to write: --- --- @'liftIOOp' ('E.bracketOnError' acquire release)@ -{-# INLINABLE bracketOnError #-} -bracketOnError ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first (\"acquire resource\") - → (α → m β) -- ^ computation to run last (\"release resource\") - → (α → m γ) -- ^ computation to run in-between - → m γ -bracketOnError before after thing = controlIO $ \runInIO → - E.bracketOnError (runInIO before) - (\m → runInIO $ m >>= after) - (\m → runInIO $ m >>= thing) - - --------------------------------------------------------------------------------- --- * Utilities --------------------------------------------------------------------------------- - --- |Generalized version of 'E.finally'. Note, any monadic side --- effects in @m@ of the \"afterward\" computation will be discarded. -{-# INLINABLE finally #-} -finally ∷ MonadControlIO m - ⇒ m α -- ^ computation to run first - → m β -- ^ computation to run afterward (even if an exception was raised) - → m α -finally a sequel = controlIO $ \runInIO → - E.finally (runInIO a) - (runInIO sequel) - --- |Generalized version of 'E.onException'. Note, any monadic side --- effects in @m@ of the \"afterward\" computation will be discarded. -{-# INLINABLE onException #-} -onException ∷ MonadControlIO m ⇒ m α → m β → m α -onException m what = controlIO $ \runInIO → - E.onException (runInIO m) - (runInIO what) - - --- The End --------------------------------------------------------------------- diff --git a/Control/Monad/IO/Control.hs b/Control/Monad/IO/Control.hs deleted file mode 100644 --- a/Control/Monad/IO/Control.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, RankNTypes #-} - -{- | -Module : Control.Monad.IO.Control -Copyright : © Bas van Dijk, Anders Kaseorg, 2011 -License : BSD-style - -Maintainer : Bas van Dijk -Stability : experimental -Portability : Requires RankNTypes - -This module defines the class 'MonadControlIO' of 'IO'-based monads into -which control operations on 'IO' (such as exception catching; see -"Control.Exception.Control") can be lifted. - -'liftIOOp' and 'liftIOOp_' enable convenient lifting of two common -special cases of control operation types. --} - -module Control.Monad.IO.Control - ( MonadControlIO(..) - , controlIO - - , liftIOOp - , liftIOOp_ - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Data.Function ( ($) ) -import Data.Monoid ( Monoid ) -import System.IO ( IO ) -import Control.Monad ( join ) - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from transformers: -import Control.Monad.IO.Class ( MonadIO ) - -import Control.Monad.Trans.Identity ( IdentityT ) -import Control.Monad.Trans.List ( ListT ) -import Control.Monad.Trans.Maybe ( MaybeT ) -import Control.Monad.Trans.Error ( ErrorT, Error ) -import Control.Monad.Trans.Reader ( ReaderT ) -import Control.Monad.Trans.State ( StateT ) -import Control.Monad.Trans.Writer ( WriterT ) -import Control.Monad.Trans.RWS ( RWST ) - -import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) -import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) -import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) - --- from monad-control (this package): -import Control.Monad.Trans.Control ( idLiftControl - , liftLiftControlBase - , RunInBase - ) - - --------------------------------------------------------------------------------- --- MonadControlIO --------------------------------------------------------------------------------- - -{-| -@MonadControlIO@ is the class of 'IO'-based monads supporting an -extra operation 'liftControlIO', enabling control operations on 'IO' to be -lifted into the monad. --} -class MonadIO m ⇒ MonadControlIO m where - {-| - @liftControlIO@ is a version of @liftControl@ that operates through an - arbitrary stack of monad transformers directly to an inner 'IO' - (analagously to how 'liftIO' is a version of @lift@). So it can - be used to lift control operations on 'IO' into any - monad in 'MonadControlIO'. For example: - - @ - foo :: 'IO' a -> 'IO' a - foo' :: 'MonadControlIO' m => m a -> m a - foo' a = 'controlIO' $ \runInIO -> -- runInIO :: m a -> 'IO' (m a) - foo $ runInIO a -- uses foo :: 'IO' (m a) -> 'IO' (m a) - @ - - Instances should satisfy similar laws as the 'MonadIO' laws: - - @liftControlIO . const . return = return@ - - @liftControlIO (const (m >>= f)) = liftControlIO (const m) >>= liftControlIO . const . f@ - - Additionally instances should satisfy: - - @'controlIO' $ \\runInIO -> runInIO m = m@ - -} - liftControlIO ∷ (RunInBase m IO → IO α) → m α - --- | An often used composition: @controlIO = 'join' . 'liftControlIO'@ -{-# INLINABLE controlIO #-} -controlIO ∷ MonadControlIO m ⇒ (RunInBase m IO → IO (m α)) → m α -controlIO = join ∘ liftControlIO - - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- - -instance MonadControlIO IO where - liftControlIO = idLiftControl - -instance MonadControlIO m ⇒ MonadControlIO (IdentityT m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (ListT m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (MaybeT m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Error e, MonadControlIO m) ⇒ MonadControlIO (ErrorT e m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (ReaderT r m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (StateT s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance MonadControlIO m ⇒ MonadControlIO (Strict.StateT s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (WriterT w m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (Strict.WriterT w m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (RWST r w s m) where - liftControlIO = liftLiftControlBase liftControlIO - -instance (Monoid w, MonadControlIO m) ⇒ MonadControlIO (Strict.RWST r w s m) where - liftControlIO = liftLiftControlBase liftControlIO - - --------------------------------------------------------------------------------- --- Convenient lifting of two common special cases of control operation types --------------------------------------------------------------------------------- - -{-| -@liftIOOp@ is a particular application of 'liftControlIO' that allows -lifting control operations of type @(a -> 'IO' b) -> 'IO' b@ -(e.g. @alloca@, @withMVar v@) to -@'MonadControlIO' m => (a -> m b) -> m b@. - -@liftIOOp f = \\g -> 'controlIO' $ \runInIO -> f $ runInIO . g@ --} -{-# INLINABLE liftIOOp #-} -liftIOOp ∷ MonadControlIO m - ⇒ ((α → IO (m β)) → IO (m γ)) - → ((α → m β) → m γ) -liftIOOp f = \g → controlIO $ \runInIO → f $ runInIO ∘ g - -{-| -@liftIOOp_@ is a particular application of 'liftControlIO' that allows -lifting control operations of type @'IO' a -> 'IO' a@ -(e.g. @block@) to @'MonadControlIO' m => m a -> m a@. - -@liftIOOp_ f = \\m -> 'controlIO' $ \runInIO -> f $ runInIO m@ --} -{-# INLINABLE liftIOOp_ #-} -liftIOOp_ ∷ MonadControlIO m - ⇒ (IO (m α) → IO (m β)) - → ( m α → m β) -liftIOOp_ f = \m → controlIO $ \runInIO → f $ runInIO m - - --- The End --------------------------------------------------------------------- diff --git a/Control/Monad/Trans/Control.hs b/Control/Monad/Trans/Control.hs --- a/Control/Monad/Trans/Control.hs +++ b/Control/Monad/Trans/Control.hs @@ -1,4 +1,12 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, RankNTypes #-} +{-# LANGUAGE CPP + , UnicodeSyntax + , NoImplicitPrelude + , RankNTypes + , TypeFamilies + , FunctionalDependencies + , FlexibleInstances + , UndecidableInstances + #-} {- | Module : Control.Monad.Trans.Control @@ -7,28 +15,29 @@ Maintainer : Bas van Dijk Stability : experimental -Portability : Requires RankNTypes -This module defines the class 'MonadTransControl' of monad transformers -through which control operations can be lifted. Instances are -included for all the standard monad transformers from the -@transformers@ library except @ContT@. - -'idLiftControl' and 'liftLiftControlBase' are provided to assist creation of -@MonadControlIO@-like classes (see "Control.Monad.IO.Control") based on core -monads other than 'IO'. +(TODO: It would be nicer if the associated /data types/ 'StT' and 'StM' were +associated /type synonyms/ instead. This would simplify a lot of code and could +make some definitions more efficient because there'll be no need to wrap the +monadic state in a data type. Unfortunately GHC has a bug which prevents this: +. I will switch to associated +type synonyms when that bug is fixed.) -} module Control.Monad.Trans.Control - ( -- * MonadTransControl - MonadTransControl(..) - , Run + ( MonadTransControl(..), Run + , MonadBaseControl (..), RunInBase + + -- * Defaults for MonadBaseControl + -- $defaults + , ComposeSt, defaultLiftBaseWith, defaultRestoreM + + -- * Utility functions , control - -- * Lifting - , idLiftControl - , RunInBase - , liftLiftControlBase + , liftBaseOp, liftBaseOp_ + + , liftBaseDiscard ) where @@ -37,15 +46,23 @@ -------------------------------------------------------------------------------- -- from base: -import Data.Function ( ($) ) +import Data.Function ( ($), const ) import Data.Monoid ( Monoid, mempty ) -import Control.Monad ( Monad, join, return, liftM ) +import Control.Monad ( Monad, (>>=), return, liftM, void ) +import System.IO ( IO ) +import GHC.Conc.Sync ( STM ) +import Data.Maybe ( Maybe ) +import Data.Either ( Either ) + +import Control.Monad.ST.Lazy ( ST ) +import qualified Control.Monad.ST.Strict as Strict ( ST ) + -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) -- from transformers: -import Control.Monad.Trans.Class ( MonadTrans, lift ) +import Control.Monad.Trans.Class ( MonadTrans ) import Control.Monad.Trans.Identity ( IdentityT(IdentityT), runIdentityT ) import Control.Monad.Trans.List ( ListT (ListT), runListT ) @@ -60,216 +77,344 @@ 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 +-- MonadTransControl type class -------------------------------------------------------------------------------- -{-| -@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: + -- | Monadic state of @t@. + data StT t ∷ * → * - @'control' $ \\run -> run t = t@ - -} - liftControl ∷ Monad m ⇒ (Run t → m α) → t m α + -- | @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 . const . return = return@ + -- + -- @liftWith (const (m >>= f)) = liftWith (const m) >>= liftWith . const . f@ + -- + -- 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. + liftWith ∷ Monad m ⇒ (Run t → m α) → t m α -type Run t = ∀ n o β - . (Monad n, Monad o, Monad (t o)) - ⇒ t n β → n (t o β) + -- | 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 ∷ Monad m ⇒ m (StT t α) → t m α --- | 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 +-- | 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'. +type Run t = ∀ n β. Monad n ⇒ t n β → n (StT t β) -------------------------------------------------------------------------------- --- Instances +-- MonadTransControl instances -------------------------------------------------------------------------------- instance MonadTransControl IdentityT where - liftControl f = IdentityT $ f run - where - run t = liftM return (runIdentityT t) + newtype StT IdentityT α = StId {unStId ∷ α} + liftWith f = IdentityT $ f $ liftM StId ∘ runIdentityT + restoreT = IdentityT ∘ liftM unStId + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} -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 +instance MonadTransControl MaybeT where + newtype StT MaybeT α = StMaybe {unStMaybe ∷ Maybe α} + liftWith f = MaybeT $ liftM return $ f $ liftM StMaybe ∘ runMaybeT + restoreT = MaybeT ∘ liftM unStMaybe + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} -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 Error e ⇒ MonadTransControl (ErrorT e) where + newtype StT (ErrorT e) α = StError {unStError ∷ Either e α} + liftWith f = ErrorT $ liftM return $ f $ liftM StError ∘ runErrorT + restoreT = ErrorT ∘ liftM unStError + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} +instance MonadTransControl ListT where + newtype StT ListT α = StList {unStList ∷ [α]} + liftWith f = ListT $ liftM return $ f $ liftM StList ∘ runListT + restoreT = ListT ∘ liftM unStList + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + instance MonadTransControl (ReaderT r) where - liftControl f = - ReaderT $ \r → - let run t = liftM return (runReaderT t r) - in f run + newtype StT (ReaderT r) α = StReader {unStReader ∷ α} + liftWith f = ReaderT $ \r → f $ \t → liftM StReader $ runReaderT t r + restoreT = ReaderT ∘ const ∘ liftM unStReader + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} 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) + newtype StT (StateT s) α = StState {unStState ∷ (α, s)} + liftWith f = StateT $ \s → + liftM (\x → (x, s)) + (f $ \t → liftM StState $ runStateT t s) + restoreT = StateT ∘ const ∘ liftM unStState + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} 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) + newtype StT (Strict.StateT s) α = StState' {unStState' ∷ (α, s)} + liftWith f = Strict.StateT $ \s → + liftM (\x → (x, s)) + (f $ \t → liftM StState' $ Strict.runStateT t s) + restoreT = Strict.StateT ∘ const ∘ liftM unStState' + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} 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) + newtype StT (WriterT w) α = StWriter {unStWriter ∷ (α, w)} + liftWith f = WriterT $ liftM (\x → (x, mempty)) + (f $ liftM StWriter ∘ runWriterT) + restoreT = WriterT ∘ liftM unStWriter + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} 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) + newtype StT (Strict.WriterT w) α = StWriter' {unStWriter' ∷ (α, w)} + liftWith f = Strict.WriterT $ liftM (\x → (x, mempty)) + (f $ liftM StWriter' ∘ Strict.runWriterT) + restoreT = Strict.WriterT ∘ liftM unStWriter' + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} 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) + newtype StT (RWST r w s) α = StRWS {unStRWS ∷ (α, s, w)} + liftWith f = RWST $ \r s → liftM (\x → (x, s, mempty)) + (f $ \t → liftM StRWS $ runRWST t r s) + restoreT mSt = RWST $ \_ _ → liftM unStRWS mSt + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} 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) + newtype StT (Strict.RWST r w s) α = StRWS' {unStRWS' ∷ (α, s, w)} + liftWith f = + Strict.RWST $ \r s → liftM (\x → (x, s, mempty)) + (f $ \t → liftM StRWS' $ Strict.runRWST t r s) + restoreT mSt = Strict.RWST $ \_ _ → liftM unStRWS' mSt + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} -------------------------------------------------------------------------------- --- Lifting +-- MonadBaseControl type class -------------------------------------------------------------------------------- -{-| -@idLiftControl@ acts as the \"identity\" 'liftControl' operation from a monad -@m@ to itself. +class MonadBase b m ⇒ MonadBaseControl b m | m → b where + -- | Monadic state of @m@. + data StM m ∷ * → * -@idLiftControl f = f $ liftM return@ + -- | @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 . const . return = return@ + -- + -- @liftBaseWith (const (m >>= f)) = liftBaseWith (const m) >>= liftBaseWith . const . f@ + -- + -- 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. + liftBaseWith ∷ (RunInBase m b → b α) → m α -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: + -- | 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 ∷ StM m α → m α -@ -class MonadIO m => MonadControlIO m where - liftControlIO :: (RunInBase m IO -> IO b) -> m b -@ +-- | 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'. +type RunInBase m b = ∀ α. m α → b (StM m α) -@ -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 β) +-------------------------------------------------------------------------------- +-- MonadBaseControl instances for all monads in the base library +-------------------------------------------------------------------------------- -{-| -@liftLiftControlBase@ is used to compose two 'liftControl' operations: -the outer provided by a 'MonadTransControl' instance, -and the inner provided as the argument. +#define BASE(M, ST) \ +instance MonadBaseControl (M) (M) where { \ + newtype StM (M) α = ST α; \ + liftBaseWith f = f $ liftM ST; \ + restoreM (ST x) = return x; \ + {-# INLINE liftBaseWith #-}; \ + {-# INLINE restoreM #-}} -It satisfies @'liftLiftControlBase' 'idLiftControl' = 'liftControl'@. +BASE(IO, StIO) +BASE(Strict.ST s, StSTS) +BASE( ST s, StST) +BASE(STM, StSTM) +BASE(Maybe, St) +BASE(Either e, StE) +BASE([], StL) +BASE((→) r, StF) +BASE(Identity, StI) +#undef BASE -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 -@ +-------------------------------------------------------------------------------- +-- Defaults for MonadBaseControl +-------------------------------------------------------------------------------- -using the 'MonadTransControl' instance of @'StateT' s@. +-- $defaults +-- +-- 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 +-- newtype StM (T m) a = StMT {unStMT :: 'ComposeSt' T m a} +-- liftBaseWith = 'defaultLiftBaseWith' StMT +-- restoreM = 'defaultRestoreM' unStMT +-- @ +-- +-- Defining an instance for a base monad @B@ is equally straightforward: +-- +-- @ +-- instance MonadBaseControl B B where +-- newtype StM B a = StMB {unStMB :: a} +-- liftBaseWith f = f $ liftM StMB +-- restoreM = return . unStMB +-- @ -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@: +-- | 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 α = StM m (StT t α) -@ -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 +-- | Default defintion 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 stM = \\f -> 'liftWith' $ \\run -> +-- 'liftBaseWith' $ \\runInBase -> +-- f $ liftM stM . runInBase . run +-- @ +defaultLiftBaseWith ∷ (MonadTransControl t, MonadBaseControl b m) + ⇒ (∀ β. ComposeSt t m β → StM (t m) β) -- ^ 'StM' constructor + → ((RunInBase (t m) b → b α) → t m α) +defaultLiftBaseWith stM = \f → liftWith $ \run → + liftBaseWith $ \runInBase → + f $ liftM stM ∘ runInBase ∘ run +{-# INLINE defaultLiftBaseWith #-} +-- | Default definition for the 'restoreM' method. +-- +-- Note that: @defaultRestoreM unStM = 'restoreT' . 'restoreM' . unStM@ +defaultRestoreM ∷ (MonadTransControl t, MonadBaseControl b m) + ⇒ (StM (t m) α → ComposeSt t m α) -- ^ 'StM' deconstructor + → (StM (t m) α → t m α) +defaultRestoreM unStM = restoreT ∘ restoreM ∘ unStM +{-# INLINE defaultRestoreM #-} --- The End --------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- MonadBaseControl transformer instances +-------------------------------------------------------------------------------- + +#define BODY(T, ST, unST) { \ + newtype StM (T m) α = ST {unST ∷ ComposeSt (T) m α}; \ + liftBaseWith = defaultLiftBaseWith ST; \ + restoreM = defaultRestoreM unST; \ + {-# INLINE liftBaseWith #-}; \ + {-# INLINE restoreM #-}} + +#define TRANS( T, ST, unST) \ + instance ( MonadBaseControl b m) ⇒ MonadBaseControl b (T m) where BODY(T, ST, unST) +#define TRANS_CTX(CTX, T, ST, unST) \ + instance (CTX, MonadBaseControl b m) ⇒ MonadBaseControl b (T m) where BODY(T, ST, unST) + +TRANS(IdentityT, StMId, unStMId) +TRANS(MaybeT, StMMaybe, unStMMaybe) +TRANS(ListT, StMList, unStMList) +TRANS(ReaderT r, StMReader, unStMReader) +TRANS(Strict.StateT s, StMStateS, unStMStateS) +TRANS( StateT s, StMState, unStMState) + +TRANS_CTX(Error e, ErrorT e, StMError, unStMError) +TRANS_CTX(Monoid w, Strict.WriterT w, StMWriterS, unStMWriterS) +TRANS_CTX(Monoid w, WriterT w, StMWriter, unStMWriter) +TRANS_CTX(Monoid w, Strict.RWST r w s, StMRWSS, unStMRWSS) +TRANS_CTX(Monoid w, RWST r w s, StMRWS, unStMRWS) + + +-------------------------------------------------------------------------------- +-- * Utility functions +-------------------------------------------------------------------------------- + +-- | An often used composition: @control f = 'liftBaseWith' f >>= 'restoreM'@ +control ∷ MonadBaseControl b m ⇒ (RunInBase m b → b (StM m α)) → m α +control f = liftBaseWith f >>= restoreM +{-# INLINE control #-} + +-- | @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 :: 'MonadBaseControl' 'IO' m => (Ptr a -> m c) -> m c@ +liftBaseOp ∷ MonadBaseControl b m + ⇒ ((α → b (StM m β)) → b (StM m γ)) + → ((α → m β) → m γ) +liftBaseOp f = \g → control $ \runInBase → f $ runInBase ∘ g +{-# INLINE 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 α) → b (StM m β)) + → ( m α → m β) +liftBaseOp_ f = \m → control $ \runInBase → f $ runInBase m +{-# INLINE 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 α) → (m () → m α) +liftBaseDiscard f = \m → liftBaseWith $ \runInBase → f $ void $ runInBase m +{-# INLINE liftBaseDiscard #-} diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +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) diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -2,9 +2,7 @@ `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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,44 +1,2 @@ -#! /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 --------------------------------------------------------------------- +import Distribution.Simple +main = defaultMain diff --git a/monad-control.cabal b/monad-control.cabal --- a/monad-control.cabal +++ b/monad-control.cabal @@ -1,44 +1,39 @@ Name: monad-control -Version: 0.2.0.3 +Version: 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@. - . - The following @critertion@ based benchmark shows that @monad-control@ - is on average about 2.5 times faster than @monad-peel@: - . - - License: BSD3 License-file: LICENSE Author: Bas van Dijk, Anders Kaseorg Maintainer: Bas van Dijk Copyright: (c) 2011 Bas van Dijk, Anders Kaseorg -Homepage: https://github.com/basvandijk/monad-control/ +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 +Build-type: Simple +Cabal-version: >= 1.6 +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@. + . + See the @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@. + . + 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. + . + The following @critertion@ based benchmark shows that @monad-control@ is on + average about 99% faster than @monad-peel@: + . + @git clone @ extra-source-files: README.markdown, NEWS --- TODO: Remove when http://hackage.haskell.org/trac/hackage/ticket/792 is fixed: -extra-source-files: test.hs - -------------------------------------------------------------------------------- source-repository head @@ -49,28 +44,10 @@ 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 + , transformers-base >= 0.4 && < 0.5 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 - --------------------------------------------------------------------------------- diff --git a/test.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- from base: -import Prelude hiding (catch) -import Data.IORef -import Data.Maybe -import Data.Typeable (Typeable) - --- from transformers: -import Control.Monad.IO.Class (liftIO) - -import Control.Monad.Trans.Identity -import Control.Monad.Trans.List -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Error -import Control.Monad.Trans.State -import qualified Control.Monad.Trans.RWS as RWS - --- from monad-control (this package): -import Control.Exception.Control -import Control.Monad.IO.Control (MonadControlIO) - --- from test-framework: -import Test.Framework (defaultMain, testGroup, Test) - - -- from test-framework-hunit: -import Test.Framework.Providers.HUnit - --- from hunit: -import Test.HUnit hiding (Test) - - -main :: IO () -main = defaultMain - [ testSuite "IdentityT" runIdentityT - , testSuite "ListT" $ fmap head . runListT - , testSuite "MaybeT" $ fmap fromJust . runMaybeT - , testSuite "ReaderT" $ flip runReaderT "reader state" - , testSuite "WriterT" runWriterT' - , testSuite "ErrorT" runErrorT' - , testSuite "StateT" $ flip evalStateT "state state" - , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state" - , testCase "ErrorT throwError" case_throwError - , testCase "WriterT tell" case_tell - ] - where - runWriterT' :: Functor m => WriterT [Int] m a -> m a - runWriterT' = fmap fst . runWriterT - runErrorT' :: Functor m => ErrorT String m () -> m () - runErrorT' = fmap (either (const ()) id) . runErrorT - runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a - runRWST' m r s = fmap fst $ RWS.evalRWST m r s - -testSuite :: MonadControlIO m => String -> (m () -> IO ()) -> Test -testSuite s run = testGroup s - [ testCase "finally" $ case_finally run - , testCase "catch" $ case_catch run - , testCase "bracket" $ case_bracket run - , testCase "bracket_" $ case_bracket_ run - , testCase "onException" $ case_onException run - ] - -ignore :: IO () -> IO () -ignore x = - catch x go - where - go :: SomeException -> IO () - go _ = return () - -data Exc = Exc - deriving (Show, Typeable) -instance Exception Exc - -one :: Int -one = 1 - -case_finally :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_finally run = do - i <- newIORef one - ignore - (run $ (do - liftIO $ writeIORef i 2 - error "error") `finally` (liftIO $ writeIORef i 3)) - j <- readIORef i - j @?= 3 - -case_catch :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_catch run = do - i <- newIORef one - run $ (do - liftIO $ writeIORef i 2 - throw Exc) `catch` (\Exc -> liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 3 - -case_bracket :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_bracket run = do - i <- newIORef one - ignore $ run $ bracket - (liftIO $ writeIORef i 2) - (\() -> liftIO $ writeIORef i 4) - (\() -> liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 4 - -case_bracket_ :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_bracket_ run = do - i <- newIORef one - ignore $ run $ bracket_ - (liftIO $ writeIORef i 2) - (liftIO $ writeIORef i 4) - (liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 4 - -case_onException :: MonadControlIO m => (m () -> IO ()) -> Assertion -case_onException run = do - i <- newIORef one - ignore $ run $ onException - (liftIO (writeIORef i 2) >> error "ignored") - (liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 3 - ignore $ run $ onException - (liftIO $ writeIORef i 4) - (liftIO $ writeIORef i 5) - k <- readIORef i - k @?= 4 - -case_throwError :: Assertion -case_throwError = do - i <- newIORef one - Left "throwError" <- runErrorT $ - (liftIO (writeIORef i 2) >> throwError "throwError") - `finally` - (liftIO $ writeIORef i 3) - j <- readIORef i - j @?= 3 - -case_tell :: Assertion -case_tell = do - i <- newIORef one - ((), w) <- runWriterT $ bracket_ - (liftIO (writeIORef i 2) >> tell [1 :: Int]) - (liftIO (writeIORef i 4) >> tell [3]) - (liftIO (writeIORef i 3) >> tell [2]) - j <- readIORef i - j @?= 4 - w @?= [2] - - ((), w') <- runWriterT $ bracket - (liftIO (writeIORef i 5) >> tell [5 :: Int]) - (const $ liftIO (writeIORef i 7) >> tell [7]) - (const $ liftIO (writeIORef i 6) >> tell [6]) - j' <- readIORef i - j' @?= 7 - w' @?= [5, 6]