diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,54 @@ +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.*. diff --git a/Control/Monad/Trans/Control.hs b/Control/Monad/Trans/Control.hs deleted file mode 100644 --- a/Control/Monad/Trans/Control.hs +++ /dev/null @@ -1,527 +0,0 @@ -{-# LANGUAGE CPP - , NoImplicitPrelude - , RankNTypes - , TypeFamilies - , FunctionalDependencies - , FlexibleInstances - , UndecidableInstances - , MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif - -#if MIN_VERSION_transformers(0,4,0) --- Hide warnings for the deprecated ErrorT transformer: -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -#endif - -{- | -Module : Control.Monad.Trans.Control -Copyright : Bas van Dijk, Anders Kaseorg -License : BSD-style - -Maintainer : Bas van Dijk -Stability : experimental --} - -module Control.Monad.Trans.Control - ( -- * MonadTransControl - MonadTransControl(..), Run - - -- ** Defaults for MonadTransControl - -- $MonadTransControlDefaults - , RunDefault, defaultLiftWith, defaultRestoreT - - -- * MonadBaseControl - , MonadBaseControl (..), RunInBase - - -- ** Defaults for MonadBaseControl - -- $MonadBaseControlDefaults - , ComposeSt, RunInBaseDefault, defaultLiftBaseWith, defaultRestoreM - - -- * Utility functions - , control, embed, embed_ - - , liftBaseOp, liftBaseOp_ - - , liftBaseDiscard, liftBaseOpDiscard - ) 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 ) - -#if MIN_VERSION_base(4,4,0) -import Control.Monad.ST.Lazy.Safe ( ST ) -import qualified Control.Monad.ST.Safe as Strict ( ST ) -#endif - --- 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.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 Control.Monad.Trans.Except ( ExceptT (ExceptT), runExceptT ) - -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 ) - -#if MIN_VERSION_base(4,3,0) -import Control.Monad ( void ) -#else -import Data.Functor (Functor, fmap) -void :: Functor f => f a -> f () -void = fmap (const ()) -#endif - -import Prelude (id) - --------------------------------------------------------------------------------- --- MonadTransControl type class --------------------------------------------------------------------------------- - -class MonadTrans t => MonadTransControl t where - -- | Monadic state of @t@. - 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 . 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 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 :: 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'. -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 wraps another monad transformer which --- already has a @MonadTransControl@ instance. For example: --- --- @ --- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} --- --- 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 #-} - - --------------------------------------------------------------------------------- --- 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 #-} - -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 #-} - -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 ListT where - type StT ListT a = [a] - liftWith f = ListT $ liftM return $ f $ runListT - restoreT = ListT - {-# 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 --------------------------------------------------------------------------------- - -class MonadBase b m => MonadBaseControl b m | m -> b where - -- | Monadic state of @m@. - 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 . 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 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 :: 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'. -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) - -#if MIN_VERSION_base(4,4,0) -BASE(Strict.ST s) -BASE( ST s) -#endif - -#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 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 = \\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(ListT) -TRANS(ReaderT r) -TRANS(Strict.StateT s) -TRANS( StateT s) -TRANS(ExceptT e) - -TRANS_CTX(Error e, ErrorT 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) - - --------------------------------------------------------------------------------- --- * Utility functions --------------------------------------------------------------------------------- - --- | An often used composition: @control f = 'liftBaseWith' f >>= 'restoreM'@ -control :: MonadBaseControl b m => (RunInBase m b -> b (StM m a)) -> m a -control f = liftBaseWith f >>= restoreM -{-# INLINABLE control #-} - --- | 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_ #-} - --- | @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 - => ((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 #-} diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,3 +1,6 @@ +[![Hackage](https://img.shields.io/hackage/v/monad-control.svg)](https://hackage.haskell.org/package/monad-control) +[![Build Status](https://travis-ci.org/basvandijk/monad-control.svg)](https://travis-ci.org/basvandijk/monad-control) + This package defines the type class `MonadControlIO`, a subset of `MonadIO` into which generic control operations such as `catch` can be lifted from `IO`. Instances are based on monad transformers in @@ -8,9 +11,6 @@ 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 `criterion`](https://github.com/basvandijk/bench-monad-peel-control) based benchmark shows that `monad-control` is on average about 2.5 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/monad-control.cabal b/monad-control.cabal --- a/monad-control.cabal +++ b/monad-control.cabal @@ -1,24 +1,29 @@ -Name: monad-control -Version: 1.0.0.5 -Synopsis: Lift control operations, like exception catching, through monad transformers -License: BSD3 -License-file: LICENSE -Author: Bas van Dijk, Anders Kaseorg -Maintainer: Bas van Dijk -Copyright: (c) 2011 Bas van Dijk, Anders Kaseorg -Homepage: https://github.com/basvandijk/monad-control -Bug-reports: https://github.com/basvandijk/monad-control/issues -Category: Control -Build-type: Simple -Cabal-version: >= 1.6 -Description: +name: monad-control +version: 1.0.3.1 +synopsis: + Lift control operations, like exception catching, through monad transformers + +license: BSD3 +license-file: LICENSE +author: Bas van Dijk, Anders Kaseorg +maintainer: + Oleg Grenrus , Bas van Dijk + +copyright: (c) 2011 Bas van Dijk, Anders Kaseorg +homepage: https://github.com/basvandijk/monad-control +bug-reports: https://github.com/basvandijk/monad-control/issues +category: Control +build-type: Simple +cabal-version: 1.12 +description: This package defines the type class @MonadBaseControl@, a subset of @MonadBase@ into which generic control operations such as @catch@ can be lifted from @IO@ or any other base monad. Instances are based on monad transformers in @MonadTransControl@, which includes all standard monad transformers in the @transformers@ library except @ContT@. . - See the @lifted-base@ package which uses @monad-control@ to lift @IO@ + See the + package which uses @monad-control@ to lift @IO@ operations from the @base@ library (like @catch@ or @bracket@) into any monad that is an instance of @MonadBase@ or @MonadBaseControl@. . @@ -27,8 +32,23 @@ and exploits the @RankNTypes@ and @TypeFamilies@ language extensions to simplify and speedup most definitions. -extra-source-files: README.markdown, CHANGELOG +extra-source-files: + CHANGELOG + README.markdown +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 + -------------------------------------------------------------------------------- source-repository head @@ -37,13 +57,14 @@ -------------------------------------------------------------------------------- -Library - Exposed-modules: Control.Monad.Trans.Control - - Build-depends: base >= 4.5 && < 5 - , stm >= 2.3 && < 3 - , transformers >= 0.2 && < 0.6 - , transformers-compat >= 0.3 && < 0.6 - , transformers-base >= 0.4.4 && < 0.5 - - Ghc-options: -Wall +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Control.Monad.Trans.Control + build-depends: + base >=4.5 && <5 + , stm >=2.3 && <3 + , transformers >=0.2 && <0.7 + , transformers-base >=0.4.4 && <0.5 + , transformers-compat >=0.3 && <0.8 diff --git a/src/Control/Monad/Trans/Control.hs b/src/Control/Monad/Trans/Control.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Control.hs @@ -0,0 +1,872 @@ +{-# LANGUAGE CPP + , NoImplicitPrelude + , RankNTypes + , TypeFamilies + , FunctionalDependencies + , FlexibleInstances + , UndecidableInstances + , MultiParamTypeClasses #-} + +{-# LANGUAGE Safe #-} + +#if MIN_VERSION_transformers(0,4,0) +-- Hide warnings for the deprecated ErrorT transformer: +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +#endif + +{- | +Copyright : Bas van Dijk, Anders Kaseorg +License : BSD3 +Maintainer : Bas van Dijk + +This module defines the type class 'MonadBaseControl', a subset of +'MonadBase' into which generic control operations such as @catch@ can be +lifted from @IO@ or any other base monad. Instances are based on monad +transformers in 'MonadTransControl', which includes all standard monad +transformers in the @transformers@ library except @ContT@. + +See the +package which uses @monad-control@ to lift @IO@ +operations from the @base@ library (like @catch@ or @bracket@) into any monad +that is an instance of @MonadBase@ or @MonadBaseControl@. + +See the following tutorial by Michael Snoyman on how to use this package: + + + +=== Quick implementation guide + +Given a base monad @B@ and a stack of transformers @T@: + +* Define instances @'MonadTransControl' T@ for all transformers @T@, using the + @'defaultLiftWith'@ and @'defaultRestoreT'@ functions on the constructor and + deconstructor of @T@. + +* Define an instance @'MonadBaseControl' B B@ for the base monad: + + @ + instance MonadBaseControl B B where + type StM B a = a + liftBaseWith f = f 'id' + restoreM = 'return' + @ + +* Define instances @'MonadBaseControl' B m => 'MonadBaseControl' B (T m)@ for + all transformers: + + @ + instance MonadBaseControl b m => MonadBaseControl b (T m) where + type StM (T m) a = 'ComposeSt' T m a + liftBaseWith f = 'defaultLiftBaseWith' + restoreM = 'defaultRestoreM' + @ +-} + +module Control.Monad.Trans.Control + ( -- * MonadTransControl + MonadTransControl(..), Run + + -- ** Defaults + -- $MonadTransControlDefaults + , RunDefault, defaultLiftWith, defaultRestoreT + -- *** Defaults for a stack of two + -- $MonadTransControlDefaults2 + , RunDefault2, defaultLiftWith2, defaultRestoreT2 + + -- * MonadBaseControl + , MonadBaseControl (..), RunInBase + + -- ** Defaults + -- $MonadBaseControlDefaults + , ComposeSt, RunInBaseDefault, defaultLiftBaseWith, defaultRestoreM + + -- * Utility functions + , control, controlT, embed, embed_, captureT, captureM + + , liftBaseOp, liftBaseOp_ + + , liftBaseDiscard, liftBaseOpDiscard + + , liftThrough + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Function ( (.), ($), const ) +import Data.Monoid ( Monoid, mempty ) +import Control.Monad ( Monad, (>>=), return, liftM ) +import System.IO ( IO ) +import Data.Maybe ( Maybe ) +import Data.Either ( Either ) +import Control.Monad ( void ) +import Prelude ( id ) + +import Control.Monad.ST.Lazy.Safe ( ST ) +import qualified Control.Monad.ST.Safe as Strict ( ST ) + +-- from stm: +import Control.Monad.STM ( STM ) + +-- from transformers: +import Control.Monad.Trans.Class ( MonadTrans ) + +import Control.Monad.Trans.Identity ( IdentityT(IdentityT), runIdentityT ) +import Control.Monad.Trans.Maybe ( MaybeT (MaybeT), runMaybeT ) +import Control.Monad.Trans.Reader ( ReaderT (ReaderT), runReaderT ) +import Control.Monad.Trans.State ( StateT (StateT), runStateT ) +import Control.Monad.Trans.Writer ( WriterT (WriterT), runWriterT ) +import Control.Monad.Trans.RWS ( RWST (RWST), runRWST ) +import Control.Monad.Trans.Except ( ExceptT (ExceptT), runExceptT ) + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.List ( ListT (ListT), runListT ) +import Control.Monad.Trans.Error ( ErrorT (ErrorT), runErrorT, Error ) +#endif + +import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST (RWST), runRWST ) +import qualified Control.Monad.Trans.State.Strict as Strict ( StateT (StateT), runStateT ) +import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT(WriterT), runWriterT ) + +import Data.Functor.Identity ( Identity ) + +-- from transformers-base: +import Control.Monad.Base ( MonadBase ) + + +-------------------------------------------------------------------------------- +-- MonadTransControl type class +-------------------------------------------------------------------------------- + +-- | The @MonadTransControl@ type class is a stronger version of @'MonadTrans'@: +-- +-- Instances of @'MonadTrans'@ know how to @'lift'@ actions in the base monad to +-- the transformed monad. These lifted actions, however, are completely unaware +-- of the monadic state added by the transformer. +-- +-- @'MonadTransControl'@ instances are aware of the monadic state of the +-- transformer and allow to save and restore this state. +-- +-- This allows to lift functions that have a monad transformer in both positive +-- and negative position. Take, for example, the function +-- +-- @ +-- withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +-- @ +-- +-- @'MonadTrans'@ instances can only lift the return type of the @withFile@ +-- function: +-- +-- @ +-- withFileLifted :: MonadTrans t => FilePath -> IOMode -> (Handle -> IO r) -> t IO r +-- withFileLifted file mode action = lift (withFile file mode action) +-- @ +-- +-- However, @'MonadTrans'@ is not powerful enough to make @withFileLifted@ +-- accept a function that returns @t IO@. The reason is that we need to take +-- away the transformer layer in order to pass the function to @'withFile'@. +-- @'MonadTransControl'@ allows us to do this: +-- +-- @ +-- withFileLifted' :: (Monad (t IO), MonadTransControl t) => FilePath -> IOMode -> (Handle -> t IO r) -> t IO r +-- withFileLifted' file mode action = liftWith (\\run -> withFile file mode (run . action)) >>= restoreT . return +-- @ +class MonadTrans t => MonadTransControl t where + -- | Monadic state of @t@. + -- + -- The monadic state of a monad transformer is the result type of its @run@ + -- function, e.g.: + -- + -- @ + -- 'runReaderT' :: 'ReaderT' r m a -> r -> m a + -- 'StT' ('ReaderT' r) a ~ a + -- + -- 'runStateT' :: 'StateT' s m a -> s -> m (a, s) + -- 'StT' ('StateT' s) a ~ (a, s) + -- + -- 'runMaybeT' :: 'MaybeT' m a -> m ('Maybe' a) + -- 'StT' 'MaybeT' a ~ 'Maybe' a + -- @ + -- + -- Provided type instances: + -- + -- @ + -- StT 'IdentityT' a ~ a + -- StT 'MaybeT' a ~ 'Maybe' a + -- StT ('ErrorT' e) a ~ 'Error' e => 'Either' e a + -- StT ('ExceptT' e) a ~ 'Either' e a + -- StT 'ListT' a ~ [a] + -- StT ('ReaderT' r) a ~ a + -- StT ('StateT' s) a ~ (a, s) + -- StT ('WriterT' w) a ~ 'Monoid' w => (a, w) + -- StT ('RWST' r w s) a ~ 'Monoid' w => (a, s, w) + -- @ + type StT t a :: * + + -- | @liftWith@ is similar to 'lift' in that it lifts a computation from + -- the argument monad to the constructed monad. + -- + -- Instances should satisfy similar laws as the 'MonadTrans' laws: + -- + -- @liftWith (\\_ -> return a) = return a@ + -- + -- @liftWith (\\_ -> m >>= f) = liftWith (\\_ -> m) >>= (\\a -> liftWith (\\_ -> f a))@ + -- + -- The difference with 'lift' is that before lifting the @m@ computation + -- @liftWith@ captures the state of @t@. It then provides the @m@ + -- computation with a 'Run' function that allows running @t n@ computations in + -- @n@ (for all @n@) on the captured state, e.g. + -- + -- @ + -- withFileLifted :: (Monad (t IO), MonadTransControl t) => FilePath -> IOMode -> (Handle -> t IO r) -> t IO r + -- withFileLifted file mode action = liftWith (\\run -> withFile file mode (run . action)) >>= restoreT . return + -- @ + -- + -- If the @Run@ function is ignored, @liftWith@ coincides with @lift@: + -- + -- @lift f = liftWith (\\_ -> f)@ + -- + -- Implementations use the @'Run'@ function associated with a transformer: + -- + -- @ + -- liftWith :: 'Monad' m => (('Monad' n => 'ReaderT' r n b -> n b) -> m a) -> 'ReaderT' r m a + -- liftWith f = 'ReaderT' (\\r -> f (\\action -> 'runReaderT' action r)) + -- + -- liftWith :: 'Monad' m => (('Monad' n => 'StateT' s n b -> n (b, s)) -> m a) -> 'StateT' s m a + -- liftWith f = 'StateT' (\\s -> 'liftM' (\\x -> (x, s)) (f (\\action -> 'runStateT' action s))) + -- + -- liftWith :: 'Monad' m => (('Monad' n => 'MaybeT' n b -> n ('Maybe' b)) -> m a) -> 'MaybeT' m a + -- liftWith f = 'MaybeT' ('liftM' 'Just' (f 'runMaybeT')) + -- @ + liftWith :: Monad m => (Run t -> m a) -> t m a + + -- | Construct a @t@ computation from the monadic state of @t@ that is + -- returned from a 'Run' function. + -- + -- Instances should satisfy: + -- + -- @liftWith (\\run -> run t) >>= restoreT . return = t@ + -- + -- @restoreT@ is usually implemented through the constructor of the monad + -- transformer: + -- + -- @ + -- 'ReaderT' :: (r -> m a) -> 'ReaderT' r m a + -- restoreT :: m a -> 'ReaderT' r m a + -- restoreT action = 'ReaderT' { runReaderT = 'const' action } + -- + -- 'StateT' :: (s -> m (a, s)) -> 'StateT' s m a + -- restoreT :: m (a, s) -> 'StateT' s m a + -- restoreT action = 'StateT' { runStateT = 'const' action } + -- + -- 'MaybeT' :: m ('Maybe' a) -> 'MaybeT' m a + -- restoreT :: m ('Maybe' a) -> 'MaybeT' m a + -- restoreT action = 'MaybeT' action + -- @ + -- + -- Example type signatures: + -- + -- @ + -- restoreT :: 'Monad' m => m a -> 'IdentityT' m a + -- restoreT :: 'Monad' m => m ('Maybe' a) -> 'MaybeT' m a + -- restoreT :: ('Monad' m, 'Error' e) => m ('Either' e a) -> 'ErrorT' e m a + -- restoreT :: 'Monad' m => m ('Either' e a) -> 'ExceptT' e m a + -- restoreT :: 'Monad' m => m [a] -> 'ListT' m a + -- restoreT :: 'Monad' m => m a -> 'ReaderT' r m a + -- restoreT :: 'Monad' m => m (a, s) -> 'StateT' s m a + -- restoreT :: ('Monad' m, 'Monoid' w) => m (a, w) -> 'WriterT' w m a + -- restoreT :: ('Monad' m, 'Monoid' w) => m (a, s, w) -> 'RWST' r w s m a + -- @ + restoreT :: Monad m => m (StT t a) -> t m a + +-- | A function that runs a transformed monad @t n@ on the monadic state that +-- was captured by 'liftWith' +-- +-- A @Run t@ function yields a computation in @n@ that returns the monadic state +-- of @t@. This state can later be used to restore a @t@ computation using +-- 'restoreT'. +-- +-- Example type equalities: +-- +-- @ +-- Run 'IdentityT' ~ forall n b. 'Monad' n => 'IdentityT' n b -> n b +-- Run 'MaybeT' ~ forall n b. 'Monad' n => 'MaybeT' n b -> n ('Maybe' b) +-- Run ('ErrorT' e) ~ forall n b. ('Monad' n, 'Error' e) => 'ErrorT' e n b -> n ('Either' e b) +-- Run ('ExceptT' e) ~ forall n b. 'Monad' n => 'ExceptT' e n b -> n ('Either' e b) +-- Run 'ListT' ~ forall n b. 'Monad' n => 'ListT' n b -> n [b] +-- Run ('ReaderT' r) ~ forall n b. 'Monad' n => 'ReaderT' r n b -> n b +-- Run ('StateT' s) ~ forall n b. 'Monad' n => 'StateT' s n b -> n (a, s) +-- Run ('WriterT' w) ~ forall n b. ('Monad' n, 'Monoid' w) => 'WriterT' w n b -> n (a, w) +-- Run ('RWST' r w s) ~ forall n b. ('Monad' n, 'Monoid' w) => 'RWST' r w s n b -> n (a, s, w) +-- @ +-- +-- This type is usually satisfied by the @run@ function of a transformer: +-- +-- @ +-- 'flip' 'runReaderT' :: r -> Run ('ReaderT' r) +-- 'flip' 'runStateT' :: s -> Run ('StateT' s) +-- 'runMaybeT' :: Run 'MaybeT' +-- @ +type Run t = forall n b. Monad n => t n b -> n (StT t b) + + +-------------------------------------------------------------------------------- +-- Defaults for MonadTransControl +-------------------------------------------------------------------------------- + +-- $MonadTransControlDefaults +-- +-- The following functions can be used to define a 'MonadTransControl' instance +-- for a monad transformer which simply is a newtype around another monad +-- transformer which already has a @MonadTransControl@ instance. For example: +-- +-- @ +-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} +-- {-\# LANGUAGE UndecidableInstances \#-} +-- {-\# LANGUAGE TypeFamilies \#-} +-- +-- newtype CounterT m a = CounterT {unCounterT :: StateT Int m a} +-- deriving (Monad, MonadTrans) +-- +-- instance MonadTransControl CounterT where +-- type StT CounterT a = StT (StateT Int) a +-- liftWith = 'defaultLiftWith' CounterT unCounterT +-- restoreT = 'defaultRestoreT' CounterT +-- @ + +-- | A function like 'Run' that runs a monad transformer @t@ which wraps the +-- monad transformer @t'@. This is used in 'defaultLiftWith'. +type RunDefault t t' = forall n b. Monad n => t n b -> n (StT t' b) + +-- | Default definition for the 'liftWith' method. +defaultLiftWith :: (Monad m, MonadTransControl n) + => (forall b. n m b -> t m b) -- ^ Monad constructor + -> (forall o b. t o b -> n o b) -- ^ Monad deconstructor + -> (RunDefault t n -> m a) + -> t m a +defaultLiftWith t unT = \f -> t $ liftWith $ \run -> f $ run . unT +{-# INLINABLE defaultLiftWith #-} + +-- | Default definition for the 'restoreT' method. +defaultRestoreT :: (Monad m, MonadTransControl n) + => (n m a -> t m a) -- ^ Monad constructor + -> m (StT n a) + -> t m a +defaultRestoreT t = t . restoreT +{-# INLINABLE defaultRestoreT #-} + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +-- $MonadTransControlDefaults2 +-- +-- The following functions can be used to define a 'MonadTransControl' instance +-- for a monad transformer stack of two. +-- +-- @ +-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-} +-- +-- newtype CalcT m a = CalcT { unCalcT :: StateT Int (ExceptT String m) a } +-- deriving (Monad, MonadTrans) +-- +-- instance MonadTransControl CalcT where +-- type StT CalcT a = StT (ExceptT String) (StT (StateT Int) a) +-- liftWith = 'defaultLiftWith2' CalcT unCalcT +-- restoreT = 'defaultRestoreT2' CalcT +-- @ + +-- | A function like 'Run' that runs a monad transformer @t@ which wraps the +-- monad transformers @n@ and @n'@. This is used in 'defaultLiftWith2'. +type RunDefault2 t n n' = forall m b. (Monad m, Monad (n' m)) => t m b -> m (StT n' (StT n b)) + +-- | Default definition for the 'liftWith' method. +defaultLiftWith2 :: (Monad m, Monad (n' m), MonadTransControl n, MonadTransControl n') + => (forall b. n (n' m) b -> t m b) -- ^ Monad constructor + -> (forall o b. t o b -> n (n' o) b) -- ^ Monad deconstructor + -> (RunDefault2 t n n' -> m a) + -> t m a +defaultLiftWith2 t unT = \f -> t $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unT +{-# INLINABLE defaultLiftWith2 #-} + +-- | Default definition for the 'restoreT' method for double 'MonadTransControl'. +defaultRestoreT2 :: (Monad m, Monad (n' m), MonadTransControl n, MonadTransControl n') + => (n (n' m) a -> t m a) -- ^ Monad constructor + -> m (StT n' (StT n a)) + -> t m a +defaultRestoreT2 t = t . restoreT . restoreT +{-# INLINABLE defaultRestoreT2 #-} + +-------------------------------------------------------------------------------- +-- MonadTransControl instances +-------------------------------------------------------------------------------- + +instance MonadTransControl IdentityT where + type StT IdentityT a = a + liftWith f = IdentityT $ f $ runIdentityT + restoreT = IdentityT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl MaybeT where + type StT MaybeT a = Maybe a + liftWith f = MaybeT $ liftM return $ f $ runMaybeT + restoreT = MaybeT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +#if !(MIN_VERSION_transformers(0,6,0)) +instance MonadTransControl ListT where + type StT ListT a = [a] + liftWith f = ListT $ liftM return $ f $ runListT + restoreT = ListT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Error e => MonadTransControl (ErrorT e) where + type StT (ErrorT e) a = Either e a + liftWith f = ErrorT $ liftM return $ f $ runErrorT + restoreT = ErrorT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} +#endif + +instance MonadTransControl (ExceptT e) where + type StT (ExceptT e) a = Either e a + liftWith f = ExceptT $ liftM return $ f $ runExceptT + restoreT = ExceptT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl (ReaderT r) where + type StT (ReaderT r) a = a + liftWith f = ReaderT $ \r -> f $ \t -> runReaderT t r + restoreT = ReaderT . const + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl (StateT s) where + type StT (StateT s) a = (a, s) + liftWith f = StateT $ \s -> + liftM (\x -> (x, s)) + (f $ \t -> runStateT t s) + restoreT = StateT . const + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadTransControl (Strict.StateT s) where + type StT (Strict.StateT s) a = (a, s) + liftWith f = Strict.StateT $ \s -> + liftM (\x -> (x, s)) + (f $ \t -> Strict.runStateT t s) + restoreT = Strict.StateT . const + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (WriterT w) where + type StT (WriterT w) a = (a, w) + liftWith f = WriterT $ liftM (\x -> (x, mempty)) + (f $ runWriterT) + restoreT = WriterT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (Strict.WriterT w) where + type StT (Strict.WriterT w) a = (a, w) + liftWith f = Strict.WriterT $ liftM (\x -> (x, mempty)) + (f $ Strict.runWriterT) + restoreT = Strict.WriterT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (RWST r w s) where + type StT (RWST r w s) a = (a, s, w) + liftWith f = RWST $ \r s -> liftM (\x -> (x, s, mempty)) + (f $ \t -> runRWST t r s) + restoreT mSt = RWST $ \_ _ -> mSt + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance Monoid w => MonadTransControl (Strict.RWST r w s) where + type StT (Strict.RWST r w s) a = (a, s, w) + liftWith f = + Strict.RWST $ \r s -> liftM (\x -> (x, s, mempty)) + (f $ \t -> Strict.runRWST t r s) + restoreT mSt = Strict.RWST $ \_ _ -> mSt + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + + +-------------------------------------------------------------------------------- +-- MonadBaseControl type class +-------------------------------------------------------------------------------- + +-- | +-- == Writing instances +-- +-- The usual way to write a @'MonadBaseControl'@ instance for a transformer +-- stack over a base monad @B@ is to write an instance @MonadBaseControl B B@ +-- for the base monad, and @MonadTransControl T@ instances for every transformer +-- @T@. Instances for @'MonadBaseControl'@ are then simply implemented using +-- @'ComposeSt'@, @'defaultLiftBaseWith'@, @'defaultRestoreM'@. +class MonadBase b m => MonadBaseControl b m | m -> b where + -- | Monadic state that @m@ adds to the base monad @b@. + -- + -- For all base (non-transformed) monads, @StM m a ~ a@: + -- + -- @ + -- StM 'IO' a ~ a + -- StM 'Maybe' a ~ a + -- StM ('Either' e) a ~ a + -- StM [] a ~ a + -- StM ((->) r) a ~ a + -- StM 'Identity' a ~ a + -- StM 'STM' a ~ a + -- StM ('ST' s) a ~ a + -- @ + -- + -- If @m@ is a transformed monad, @m ~ t b@, @'StM'@ is the monadic state of + -- the transformer @t@ (given by its 'StT' from 'MonadTransControl'). For a + -- transformer stack, @'StM'@ is defined recursively: + -- + -- @ + -- StM ('IdentityT' m) a ~ 'ComposeSt' 'IdentityT' m a ~ StM m a + -- StM ('MaybeT' m) a ~ 'ComposeSt' 'MaybeT' m a ~ StM m ('Maybe' a) + -- StM ('ErrorT' e m) a ~ 'ComposeSt' 'ErrorT' m a ~ 'Error' e => StM m ('Either' e a) + -- StM ('ExceptT' e m) a ~ 'ComposeSt' 'ExceptT' m a ~ StM m ('Either' e a) + -- StM ('ListT' m) a ~ 'ComposeSt' 'ListT' m a ~ StM m [a] + -- StM ('ReaderT' r m) a ~ 'ComposeSt' 'ReaderT' m a ~ StM m a + -- StM ('StateT' s m) a ~ 'ComposeSt' 'StateT' m a ~ StM m (a, s) + -- StM ('WriterT' w m) a ~ 'ComposeSt' 'WriterT' m a ~ 'Monoid' w => StM m (a, w) + -- StM ('RWST' r w s m) a ~ 'ComposeSt' 'RWST' m a ~ 'Monoid' w => StM m (a, s, w) + -- @ + type StM m a :: * + + -- | @liftBaseWith@ is similar to 'liftIO' and 'liftBase' in that it + -- lifts a base computation to the constructed monad. + -- + -- Instances should satisfy similar laws as the 'MonadIO' and 'MonadBase' laws: + -- + -- @liftBaseWith (\\_ -> return a) = return a@ + -- + -- @liftBaseWith (\\_ -> m >>= f) = liftBaseWith (\\_ -> m) >>= (\\a -> liftBaseWith (\\_ -> f a))@ + -- + -- As , parametricity + -- guarantees that + -- + -- @f <$> liftBaseWith q = liftBaseWith $ \runInBase -> f <$> q runInBase@ + -- + -- The difference with 'liftBase' is that before lifting the base computation + -- @liftBaseWith@ captures the state of @m@. It then provides the base + -- computation with a 'RunInBase' function that allows running @m@ + -- computations in the base monad on the captured state: + -- + -- @ + -- withFileLifted :: MonadBaseControl IO m => FilePath -> IOMode -> (Handle -> m a) -> m a + -- withFileLifted file mode action = liftBaseWith (\\runInBase -> withFile file mode (runInBase . action)) >>= restoreM + -- -- = control $ \\runInBase -> withFile file mode (runInBase . action) + -- -- = liftBaseOp (withFile file mode) action + -- @ + -- + -- @'liftBaseWith'@ is usually not implemented directly, but using + -- @'defaultLiftBaseWith'@. + liftBaseWith :: (RunInBase m b -> b a) -> m a + + -- | Construct a @m@ computation from the monadic state of @m@ that is + -- returned from a 'RunInBase' function. + -- + -- Instances should satisfy: + -- + -- @liftBaseWith (\\runInBase -> runInBase m) >>= restoreM = m@ + -- + -- @'restoreM'@ is usually not implemented directly, but using + -- @'defaultRestoreM'@. + restoreM :: StM m a -> m a + +-- | A function that runs a @m@ computation on the monadic state that was +-- captured by 'liftBaseWith' +-- +-- A @RunInBase m@ function yields a computation in the base monad of @m@ that +-- returns the monadic state of @m@. This state can later be used to restore the +-- @m@ computation using 'restoreM'. +-- +-- Example type equalities: +-- +-- @ +-- RunInBase ('IdentityT' m) b ~ forall a. 'IdentityT' m a -> b ('StM' m a) +-- RunInBase ('MaybeT' m) b ~ forall a. 'MaybeT' m a -> b ('StM' m ('Maybe' a)) +-- RunInBase ('ErrorT' e m) b ~ forall a. 'Error' e => 'ErrorT' e m a -> b ('StM' m ('Either' e a)) +-- RunInBase ('ExceptT' e m) b ~ forall a. 'ExceptT' e m a -> b ('StM' m ('Either' e a)) +-- RunInBase ('ListT' m) b ~ forall a. 'ListT' m a -> b ('StM' m [a]) +-- RunInBase ('ReaderT' r m) b ~ forall a. 'ReaderT' m a -> b ('StM' m a) +-- RunInBase ('StateT' s m) b ~ forall a. 'StateT' s m a -> b ('StM' m (a, s)) +-- RunInBase ('WriterT' w m) b ~ forall a. 'Monoid' w => 'WriterT' w m a -> b ('StM' m (a, w)) +-- RunInBase ('RWST' r w s m) b ~ forall a. 'Monoid' w => 'RWST' r w s m a -> b ('StM' m (a, s, w)) +-- @ +-- +-- For a transformed base monad @m ~ t b@, @'RunInBase m b' ~ 'Run' t@. +type RunInBase m b = forall a. m a -> b (StM m a) + + +-------------------------------------------------------------------------------- +-- MonadBaseControl instances for all monads in the base library +-------------------------------------------------------------------------------- + +#define BASE(M) \ +instance MonadBaseControl (M) (M) where { \ + type StM (M) a = a; \ + liftBaseWith f = f id; \ + restoreM = return; \ + {-# INLINABLE liftBaseWith #-}; \ + {-# INLINABLE restoreM #-}} + +BASE(IO) +BASE(Maybe) +BASE(Either e) +BASE([]) +BASE((->) r) +BASE(Identity) + +BASE(STM) + +BASE(Strict.ST s) +BASE( ST s) + +#undef BASE + + +-------------------------------------------------------------------------------- +-- Defaults for MonadBaseControl +-------------------------------------------------------------------------------- + +-- $MonadBaseControlDefaults +-- +-- Note that by using the following default definitions it's easy to make a +-- monad transformer @T@ an instance of 'MonadBaseControl': +-- +-- @ +-- instance MonadBaseControl b m => MonadBaseControl b (T m) where +-- type StM (T m) a = 'ComposeSt' T m a +-- liftBaseWith = 'defaultLiftBaseWith' +-- restoreM = 'defaultRestoreM' +-- @ +-- +-- Defining an instance for a base monad @B@ is equally straightforward: +-- +-- @ +-- instance MonadBaseControl B B where +-- type StM B a = a +-- liftBaseWith f = f 'id' +-- restoreM = 'return' +-- @ + +-- | Handy type synonym that composes the monadic states of @t@ and @m@. +-- +-- It can be used to define the 'StM' for new 'MonadBaseControl' instances. +type ComposeSt t m a = StM m (StT t a) + +-- | A function like 'RunInBase' that runs a monad transformer @t@ in its base +-- monad @b@. It is used in 'defaultLiftBaseWith'. +type RunInBaseDefault t m b = forall a. t m a -> b (ComposeSt t m a) + +-- | Default definition for the 'liftBaseWith' method. +-- +-- Note that it composes a 'liftWith' of @t@ with a 'liftBaseWith' of @m@ to +-- give a 'liftBaseWith' of @t m@: +-- +-- @ +-- defaultLiftBaseWith = \\f -> 'liftWith' $ \\run -> +-- 'liftBaseWith' $ \\runInBase -> +-- f $ runInBase . run +-- @ +defaultLiftBaseWith :: (MonadTransControl t, MonadBaseControl b m) + => (RunInBaseDefault t m b -> b a) -> t m a +defaultLiftBaseWith = \f -> liftWith $ \run -> + liftBaseWith $ \runInBase -> + f $ runInBase . run +{-# INLINABLE defaultLiftBaseWith #-} + +-- | Default definition for the 'restoreM' method. +-- +-- Note that: @defaultRestoreM = 'restoreT' . 'restoreM'@ +defaultRestoreM :: (MonadTransControl t, MonadBaseControl b m) + => ComposeSt t m a -> t m a +defaultRestoreM = restoreT . restoreM +{-# INLINABLE defaultRestoreM #-} + + +-------------------------------------------------------------------------------- +-- MonadBaseControl transformer instances +-------------------------------------------------------------------------------- + +#define BODY(T) { \ + type StM (T m) a = ComposeSt (T) m a; \ + liftBaseWith = defaultLiftBaseWith; \ + restoreM = defaultRestoreM; \ + {-# INLINABLE liftBaseWith #-}; \ + {-# INLINABLE restoreM #-}} + +#define TRANS( T) \ + instance ( MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T) +#define TRANS_CTX(CTX, T) \ + instance (CTX, MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T) + +TRANS(IdentityT) +TRANS(MaybeT) +TRANS(ReaderT r) +TRANS(Strict.StateT s) +TRANS( StateT s) +TRANS(ExceptT e) + +TRANS_CTX(Monoid w, Strict.WriterT w) +TRANS_CTX(Monoid w, WriterT w) +TRANS_CTX(Monoid w, Strict.RWST r w s) +TRANS_CTX(Monoid w, RWST r w s) + +#if !(MIN_VERSION_transformers(0,6,0)) +TRANS(ListT) +TRANS_CTX(Error e, ErrorT e) +#endif + +#undef BODY +#undef TRANS +#undef TRANS_CTX + +-------------------------------------------------------------------------------- +-- * Utility functions +-------------------------------------------------------------------------------- + +-- | An often used composition: @control f = 'liftBaseWith' f >>= 'restoreM'@ +-- +-- Example: +-- +-- @ +-- liftedBracket :: MonadBaseControl IO m => m a -> (a -> m b) -> (a -> m c) -> m c +-- liftedBracket acquire release action = control $ \\runInBase -> +-- bracket (runInBase acquire) +-- (\\saved -> runInBase (restoreM saved >>= release)) +-- (\\saved -> runInBase (restoreM saved >>= action)) +-- @ +control :: MonadBaseControl b m => (RunInBase m b -> b (StM m a)) -> m a +control f = liftBaseWith f >>= restoreM +{-# INLINABLE control #-} + +-- | Lift a computation and restore the monadic state immediately: +-- @controlT f = 'liftWith' f >>= 'restoreT' . return@. +controlT :: (MonadTransControl t, Monad (t m), Monad m) + => (Run t -> m (StT t a)) -> t m a +controlT f = liftWith f >>= restoreT . return +{-# INLINABLE controlT #-} + +-- | Embed a transformer function as an function in the base monad returning a +-- mutated transformer state. +embed :: MonadBaseControl b m => (a -> m c) -> m (a -> b (StM m c)) +embed f = liftBaseWith $ \runInBase -> return (runInBase . f) +{-# INLINABLE embed #-} + +-- | Performs the same function as 'embed', but discards transformer state +-- from the embedded function. +embed_ :: MonadBaseControl b m => (a -> m ()) -> m (a -> b ()) +embed_ f = liftBaseWith $ \runInBase -> return (void . runInBase . f) +{-# INLINABLE embed_ #-} + +-- | Capture the current state of a transformer +captureT :: (MonadTransControl t, Monad (t m), Monad m) => t m (StT t ()) +captureT = liftWith $ \runInM -> runInM (return ()) +{-# INLINABLE captureT #-} + +-- | Capture the current state above the base monad +captureM :: MonadBaseControl b m => m (StM m ()) +captureM = liftBaseWith $ \runInBase -> runInBase (return ()) +{-# INLINABLE captureM #-} + +-- | @liftBaseOp@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @((a -> b c) -> b c)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => (a -> m c) -> m c)@ +-- +-- For example: +-- +-- @liftBaseOp alloca :: (Storable a, 'MonadBaseControl' 'IO' m) => (Ptr a -> m c) -> m c@ +liftBaseOp :: MonadBaseControl b m + => ((a -> b (StM m c)) -> b (StM m d)) + -> ((a -> m c) -> m d) +liftBaseOp f = \g -> control $ \runInBase -> f $ runInBase . g +{-# INLINABLE liftBaseOp #-} + +-- | @liftBaseOp_@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @(b a -> b a)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => m a -> m a)@ +-- +-- For example: +-- +-- @liftBaseOp_ mask_ :: 'MonadBaseControl' 'IO' m => m a -> m a@ +liftBaseOp_ :: MonadBaseControl b m + => (b (StM m a) -> b (StM m c)) + -> ( m a -> m c) +liftBaseOp_ f = \m -> control $ \runInBase -> f $ runInBase m +{-# INLINABLE liftBaseOp_ #-} + +-- | @liftBaseDiscard@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @(b () -> b a)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => m () -> m a)@ +-- +-- Note that, while the argument computation @m ()@ has access to the captured +-- state, all its side-effects in @m@ are discarded. It is run only for its +-- side-effects in the base monad @b@. +-- +-- For example: +-- +-- @liftBaseDiscard forkIO :: 'MonadBaseControl' 'IO' m => m () -> m ThreadId@ +liftBaseDiscard :: MonadBaseControl b m => (b () -> b a) -> (m () -> m a) +liftBaseDiscard f = \m -> liftBaseWith $ \runInBase -> f $ void $ runInBase m +{-# INLINABLE liftBaseDiscard #-} + +-- | @liftBaseOpDiscard@ is a particular application of 'liftBaseWith' that allows +-- lifting control operations of type: +-- +-- @((a -> b ()) -> b c)@ +-- +-- to: +-- +-- @('MonadBaseControl' b m => (a -> m ()) -> m c)@ +-- +-- Note that, while the argument computation @m ()@ has access to the captured +-- state, all its side-effects in @m@ are discarded. It is run only for its +-- side-effects in the base monad @b@. +-- +-- For example: +-- +-- @liftBaseDiscard (runServer addr port) :: 'MonadBaseControl' 'IO' m => m () -> m ()@ +liftBaseOpDiscard :: MonadBaseControl b m + => ((a -> b ()) -> b c) + -> (a -> m ()) -> m c +liftBaseOpDiscard f g = liftBaseWith $ \runInBase -> f $ void . runInBase . g +{-# INLINABLE liftBaseOpDiscard #-} + +-- | Transform an action in @t m@ using a transformer that operates on the underlying monad @m@ +liftThrough + :: (MonadTransControl t, Monad (t m), Monad m) + => (m (StT t a) -> m (StT t b)) -- ^ + -> t m a -> t m b +liftThrough f t = do + st <- liftWith $ \run -> do + f $ run t + restoreT $ return st