monad-control (empty) → 0.1
raw patch · 7 files changed
+1025/−0 lines, 7 filesdep +HUnitdep +basedep +base-unicode-symbolsbuild-type:Customsetup-changed
Dependencies added: HUnit, base, base-unicode-symbols, test-framework, test-framework-hunit, transformers
Files
- Control/Exception/Control.hs +303/−0
- Control/Monad/IO/Control.hs +160/−0
- Control/Monad/Trans/Control.hs +228/−0
- LICENSE +29/−0
- Setup.hs +62/−0
- monad-control.cabal +84/−0
- test.hs +159/−0
+ Control/Exception/Control.hs view
@@ -0,0 +1,303 @@+{-# 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+ , blocked++ -- * Utilities+ , bracket, bracket_, bracketOnError+ , finally, onException+ ) where+++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Data.Function ( ($) )+import Data.Either ( Either(Left, Right) )+import Data.Maybe ( Maybe )+import Data.Bool ( Bool )+import Control.Monad ( Monad, (>>=), return, liftM )+import System.IO.Error ( IOError )++#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+ , blocked+ , bracket, bracket_, bracketOnError+ , finally, onException+ )+import qualified Control.Exception as E++-- from monad-control (this package):+import Control.Monad.IO.Control ( MonadControlIO+ , controlIO+ , liftIOOp_+ )+++--------------------------------------------------------------------------------+-- * Throwing exceptions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.throwIO'.+throwIO ∷ (MonadIO m, Exception e) ⇒ e → m a+throwIO = liftIO ∘ E.throwIO++-- |Generalized version of 'E.ioError'.+ioError ∷ MonadIO m ⇒ IOError → m a+ioError = liftIO ∘ E.ioError+++--------------------------------------------------------------------------------+-- * Catching exceptions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.catch'.+catch ∷ (MonadControlIO m, Exception e)+ ⇒ m a -- ^ The computation to run+ → (e → m a) -- ^ Handler to invoke if an exception is raised+ → m a+catch a handler = controlIO $ \runInIO →+ E.catch (runInIO a)+ (\e → runInIO $ handler e)++-- |Generalized version of 'E.catches'.+catches ∷ MonadControlIO m ⇒ m a → [Handler m a] → m a+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 a = ∀ e. Exception e ⇒ Handler (e → m a)++-- |Generalized version of 'E.catchJust'.+catchJust ∷ (MonadControlIO m, Exception e)+ ⇒ (e → Maybe b) -- ^ Predicate to select exceptions+ → m a -- ^ Computation to run+ → (b → m a) -- ^ Handler+ → m a+catchJust p a handler = controlIO $ \runInIO →+ E.catchJust p+ (runInIO a)+ (\e → runInIO (handler e))+++--------------------------------------------------------------------------------+-- ** The @handle@ functions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.handle'.+handle ∷ (MonadControlIO m, Exception e) ⇒ (e → m a) → m a → m a+handle handler a = controlIO $ \runInIO →+ E.handle (\e → runInIO (handler e))+ (runInIO a)++-- |Generalized version of 'E.handleJust'.+handleJust ∷ (MonadControlIO m, Exception e)+ ⇒ (e → Maybe b) → (b → m a) → m a → m a+handleJust p handler a = controlIO $ \runInIO →+ E.handleJust p (\e → runInIO (handler e))+ (runInIO a)++sequenceEither ∷ Monad m ⇒ Either e (m a) → m (Either e a)+sequenceEither (Left e) = return $ Left e+sequenceEither (Right m) = liftM Right m+++--------------------------------------------------------------------------------+-- ** The @try@ functions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.try'.+try ∷ (MonadControlIO m, Exception e) ⇒ m a → m (Either e a)+try = liftIOOp_ (liftM sequenceEither ∘ E.try)++-- |Generalized version of 'E.tryJust'.+tryJust ∷ (MonadControlIO m, Exception e) ⇒+ (e → Maybe b) → m a → m (Either b a)+tryJust p = liftIOOp_ (liftM sequenceEither ∘ E.tryJust p)+++--------------------------------------------------------------------------------+-- ** The @evaluate@ function+--------------------------------------------------------------------------------++-- |Generalized version of 'E.evaluate'.+evaluate ∷ MonadIO m ⇒ a → m a+evaluate = liftIO ∘ E.evaluate+++--------------------------------------------------------------------------------+-- ** Asynchronous exception control+--------------------------------------------------------------------------------++#if MIN_VERSION_base(4,3,0)+-- |Generalized version of 'E.mask'.+mask ∷ MonadControlIO m ⇒ ((∀ a. m a → m a) → m b) → m b+mask f = controlIO $ \runInIO →+ E.mask $ \restore →+ runInIO $ f $ liftIOOp_ restore++-- |Generalized version of 'E.mask_'.+mask_ ∷ MonadControlIO m ⇒ m a → m a+mask_ = liftIOOp_ E.mask_++-- |Generalized version of 'E.uninterruptibleMask'.+uninterruptibleMask ∷ MonadControlIO m ⇒ ((∀ a. m a → m a) → m b) → m b+uninterruptibleMask f = controlIO $ \runInIO →+ E.uninterruptibleMask $ \restore →+ runInIO $ f $ liftIOOp_ restore++-- |Generalized version of 'E.uninterruptibleMask_'.+uninterruptibleMask_ ∷ MonadControlIO m ⇒ m a → m a+uninterruptibleMask_ = liftIOOp_ E.uninterruptibleMask_++-- |Generalized version of 'E.getMaskingState'.+getMaskingState ∷ MonadIO m ⇒ m MaskingState+getMaskingState = liftIO E.getMaskingState+#else+-- |Generalized version of 'E.block'.+block ∷ MonadControlIO m ⇒ m a → m a+block = liftIOOp_ E.block++-- |Generalized version of 'E.unblock'.+unblock ∷ MonadControlIO m ⇒ m a → m a+unblock = liftIOOp_ E.unblock+#endif++-- | 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+++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++-- |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@.+bracket ∷ MonadControlIO m+ ⇒ m a -- ^ computation to run first (\"acquire resource\")+ → (a → m b) -- ^ computation to run last (\"release resource\")+ → (a → m c) -- ^ computation to run in-between+ → m c+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.+bracket_ ∷ MonadControlIO m ⇒ m a → m b → m c → m c+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.+bracketOnError ∷ MonadControlIO m+ ⇒ m a -- ^ computation to run first (\"acquire resource\")+ → (a → m b) -- ^ computation to run last (\"release resource\")+ → (a → m c) -- ^ computation to run in-between+ → m c+bracketOnError before after thing = controlIO $ \runInIO →+ E.bracketOnError (runInIO before)+ (\m → runInIO $ m >>= after)+ (\m → runInIO $ m >>= thing)++-- |Generalized version of 'E.finally'. Note, any monadic side+-- effects in @m@ of the \"afterward\" computation will be discarded.+finally ∷ MonadControlIO m+ ⇒ m a -- ^ computation to run first+ → m b -- ^ computation to run afterward (even if an exception was raised)+ → m a+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.+onException ∷ MonadControlIO m ⇒ m a → m b → m a+onException m what = controlIO $ \runInIO →+ E.onException (runInIO m)+ (runInIO what)+++-- The End ---------------------------------------------------------------------
+ Control/Monad/IO/Control.hs view
@@ -0,0 +1,160 @@+{-# 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)+ -- @+ liftControlIO ∷ (RunInBase m IO → IO b) → m b++-- | An often used composition: @controlIO = 'join' . 'liftControlIO'@+controlIO ∷ MonadControlIO m ⇒ (RunInBase m IO → IO (m b)) → m b+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@++liftIOOp ∷ MonadControlIO m+ ⇒ ((a → IO (m b)) → IO (m c))+ → (a → m b) → m c+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@+liftIOOp_ ∷ MonadControlIO m+ ⇒ (IO (m a) → IO (m b))+ → m a → m b+liftIOOp_ f = \m → controlIO $ \runInIO → f $ runInIO m+++-- The End ---------------------------------------------------------------------
+ Control/Monad/Trans/Control.hs view
@@ -0,0 +1,228 @@+{-# 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 b@.+ --+ -- More precisely, @liftControl@ captures the monadic state of @t@ at the+ -- point where it is bound (in @t n@), yielding a function of type+ -- @'Run' t n o = t n a -> n (t o a)@+ -- this function runs a transformed monadic action @t n a@+ -- in the base monad @n@ using the captured state, and leaves the+ -- result @t o a@ 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)+ -- @+ --+ -- @liftControl@ is typically used with @m == n == o@, but is required to+ -- be polymorphic for greater type safety: for example, this type+ -- ensures that the result of running the action in @m@ has no+ -- remaining side effects in @m@.+ liftControl ∷ (Monad m, Monad n, Monad o) ⇒ (Run t n o → m a) → t m a++type Run t n o = ∀ b. t n b → n (t o b)++-- | An often used composition: @control = 'join' . 'liftControl'@+control ∷ (Monad n, Monad m, Monad o, Monad (t m), MonadTransControl t)+ ⇒ (Run t n o → m (t m a)) → t m a+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 n, Monad o, Monad f)+ ⇒ (∀ a p. p (f a) → t p a)+ → (∀ a. t m a → m (f a))+ → (Run t m o → n b) → t n b+liftControlNoState mkT runT = \f → mkT $ liftM return $ f run+ where+ run = 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 (WriterT ∘ return) (runWriterT t)++instance Monoid w ⇒ MonadTransControl (Strict.WriterT w) where+ liftControl f = Strict.WriterT $ liftM (\x → (x, mempty)) (f run)+ where+ run t = liftM (Strict.WriterT ∘ return) (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 ⇒ ((∀ b. m b → m (m b)) → m a) → m a+idLiftControl f = f $ liftM return++type RunInBase m base = ∀ b. m b → base (m b)++-- |@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@.+liftLiftControlBase ∷ (MonadTransControl t, Monad base, Monad m, Monad (t m))+ ⇒ ((RunInBase m base → base a) → m a) -- ^ @liftControlBase@ operation+ → ((RunInBase (t m) base → base a) → t m a)+liftLiftControlBase lftCtrlBase = \f → liftControl $ \run →+ lftCtrlBase $ \runInBase →+ f $ liftM (join ∘ lift) ∘ runInBase ∘ run+++-- The End ---------------------------------------------------------------------
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright © 2010, Bas van Dijk, Anders Kaseorg+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++• Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++• Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++• Neither the name of the author nor the names of other contributors+ may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+“AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,62 @@+#! /usr/bin/env runhaskell++{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}++module Main (main) where+++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++-- from base+import Control.Monad ( (>>), return )+import Data.Bool ( Bool )+import System.Cmd ( system )+import System.FilePath ( (</>) )+import System.IO ( IO )++-- from cabal+import Distribution.Simple ( defaultMainWithHooks+ , simpleUserHooks+ , UserHooks(runTests, haddockHook)+ , Args+ )++import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.Program ( userSpecifyArgs )+import Distribution.Simple.Setup ( HaddockFlags )+import Distribution.PackageDescription ( PackageDescription(..) )+++-------------------------------------------------------------------------------+-- Cabal setup program with support for 'cabal test' and+-- which sets the CPP define '__HADDOCK __' when haddock is run.+-------------------------------------------------------------------------------++main ∷ IO ()+main = defaultMainWithHooks hooks+ where+ hooks = simpleUserHooks+ { runTests = runTests'+ , haddockHook = haddockHook'+ }++-- Run a 'test' binary that gets built when configured with '-ftest'.+runTests' ∷ Args → Bool → PackageDescription → LocalBuildInfo → IO ()+runTests' _ _ _ _ = system testcmd >> return ()+ where testcmd = "."+ </> "dist"+ </> "build"+ </> "test-monad-control"+ </> "test-monad-control"++-- 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
@@ -0,0 +1,84 @@+Name: monad-control+Version: 0.1+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 about+ 2 times faster than @monad-peel@:+ .+ <http://code.haskell.org/~basvandijk/code/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+Category: Control+Build-type: Custom+Cabal-version: >= 1.6++--------------------------------------------------------------------------------++source-repository head+ type: darcs+ location: http://code.haskell.org/~basvandijk/code/monad-control++--------------------------------------------------------------------------------++flag test+ description: Build the testing suite+ default: False++flag hpc+ description: Enable program coverage on test executable+ default: False++--------------------------------------------------------------------------------++Library+ Exposed-modules: Control.Monad.Trans.Control+ Control.Monad.IO.Control+ Control.Exception.Control++ Build-depends: base >= 3 && < 4.4+ , base-unicode-symbols >= 0.1.1 && < 0.3+ , transformers >= 0.2 && < 0.3++ Ghc-options: -Wall++--------------------------------------------------------------------------------++executable test-monad-control+ main-is: test.hs++ ghc-options: -Wall++ if flag(test)+ build-depends: base >= 3 && < 4.4+ , base-unicode-symbols >= 0.1.1 && < 0.3+ , HUnit >= 1.2.2 && < 1.3+ , test-framework >= 0.2.4 && < 0.4+ , test-framework-hunit >= 0.2.4 && < 0.3+ buildable: True+ else+ buildable: False++ if flag(hpc)+ ghc-options: -fhpc++--------------------------------------------------------------------------------
+ test.hs view
@@ -0,0 +1,159 @@+{-# 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]