diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,153 @@ +# multistate + +[![Build Status](https://secure.travis-ci.org/lspitzner/multistate.svg)](http://travis-ci.org/lspitzner/multistate) + +## Introduction + +When using multiple Reader/Writer/State transformers in the same monad +stack, it becomes necessary to lift the operations in order to affect a +specific transformer. +Using heterogeneous lists (and all kinds of GHC extensions magic), +this package provides transformers that remove that necessity: +MultiReaderT/MultiWriterT/MultiStateT can contain a heterogeneous +list of values. + +The type inferred for the getter/setter determines which value is +read/written. + +## Example + +~~~~ +simpleExample :: IO () +simpleExample = evalMultiStateT -- start with an empty state, + -- i.e. :: MultiStateT '[] IO + $ withMultiState 'H' -- "adding" a char to the state + $ withMultiState "ello, World!" -- and a string + $ do -- so: + -- the monad here is MultiStateT '[String, Char] IO + let combinedPrint = do -- no type signature necessary + c <- mGet -- type of mGet inferred to be m Char + cs <- mGet -- inferred to be m String + lift $ putStrLn (c:cs) + combinedPrint + mSet 'J' -- we modify the Char in the state. + -- again, the type is inferred, + -- without any manual lifting. + combinedPrint +~~~~ + +The output is: + +~~~~ +Hello, World! +Jello, World! +~~~~ + +( you can find both this and a more complex example + in an executable in the package. ) + +## Error Messages + +If you try to execute an action that requires a specific type in the state, +but the current state does not contain that type, the error message is +something like + +~~~~ +No instance for (Control.Monad.MultiState.ContainsType Foo '[]) x +~~~~ + +where `Foo` is the missing type. + +## Compatibility with Single-Valued Transformers + +It is possible to run single-valued actions inside multi-valued +transformers using the `inflate` functions. A function transforming +a multi-valued transformer with exactly one element into a +single-valued transformer would be trivial, but it is currently not provided. + +## Naming Scheme + +(Will refer to StateT in this paragraph, but equally valid for Reader/Writer) +The mtl monad transformers make use of primarily three methods to "unwrap" +a transformed value: +`runStateT`, `evalStateT`, `execStateT`. These three all have a type +matching the pattern `s -> t m a -> m b`, they differ in what `b` is. +We will use a different naming scheme, for three reasons: + +1) "run", "eval" and "exec" are not in any way intuitive, and should be + suffixed in any case. + +2) For MultiStateT, it makes sense to transform an existing transformer, + adding another state. The signature would be close to that of runStateT, + only without the unwrapping part, i.e. `s -> t m a -> t' m b`, where `s` + is the initial state, and `t` is `t'` with another state added. + +3) Sometimes you might want to add/run a single state, or a bunch of them. + For example, when running an arbitrary StateT, you would need to provide + a HList of initial states, and would receive a HList of final states. + +Our naming scheme will instead be: + +1) `runStateT.*` unwraps a StateT. A suffix controls + what exactly is returned by the function. There is a special version for + when the list of states is Nil, `runStateTNil`. + +2) `withStateT.*` adds one or more states to a subcomputation. A suffix + controls the exact return value. + +~~~~ + withStates + /-------------------------------------------------------\ + | withState withState .. withState v +StateT '[s, ..] m --------> StateT '[..] m --------> .. --------> StateT '[] m + | | + | | + | runStateT runStateTNil | + \--------------------> m .. <---------------------------/ +~~~~ + +Specific functions are + +~~~~ +runMultiStateT = runStateTAS +runMultiStateTA :: HList s -> MultiStateT s m a -> m a +runMultiStateTAS :: HList s -> MultiStateT s m a -> m (a, s) +runMultiStateTSA :: HList s -> MultiStateT s m a -> m (s, a) +runMultiStateTS :: HList s -> MultiStateT s m a -> m s +runMultiStateT_ :: HList s -> MultiStateT s m a -> m () + +runMultiStateTNil :: MultiStateT '[] m a -> m a +runMultiStateTNil_ :: MultiStateT '[] m a -> m () + +withMultiState = withStateAS +withMultiStateA :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m a +withMultiStateAS :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) +withMultiStateSA :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (s, a) +withMultiStateS :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m s +withMultiState_ :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m () + +withMultiStates = withStatesAS +withMultiStatesAS :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) +withMultiStatesSA :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1, a) +withMultiStatesA :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m a +withMultiStatesS :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1) +withMultiStates_ :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m () +~~~~ + +## Known Deficits + +This package currently lacks a complete set of "lifting instances", i.e. +instance definitions for classes such as mtl's MonadWriter "over" the newly +introduced monad transformers, as in + +~~~~ +instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where .. +~~~~ + +These "lifting instances" would be necessary +to achieve full compatibility with existing transformers. Ping me if you +find anything specific missing. + +## Changelog + +See changelog.md diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,83 @@ +# Changelog for [`multistate` package](https://hackage.haskell.org/package/multistate) + +## 0.6.0.0 *June 2015* + + * Add `MultiRWST` + + * Add inflate functions (e.g. `StateT _ -> MultiStateT _`) + + * Improve lazyness + + * Move changelog from `README.md` to `changelog.md` + +## 0.5.0.0 *March 2015* + + * Breaking changes (!): + + Refactor some parts of the interface, see "naming scheme" in the README; + The changes are: + + | old | new | + | --- | --- | + | `withMultiFoo` | `withMultiFooA` | + | `withMultiFoos` | `withMultiFoosA` | + | `mAskRaw` | `mGetRaw` | + | | `mPutRaw` | + | `evalMultiStateT` | `runMultiStateTNil` | + | `evalMultiStateTWithInitial` | `runMultiStateTA` | + | `evalMultiReaderT` | `runMultiReaderTNil` | + | `evalMultiReaderTWithInitial` | `runMultiReaderTA` | + | `execMultiWriterT` | `runMultiWriterTW` | + + * Start using hspec; Add proper cabal test-suite. + +## 0.4.0.0: *March 2015* + + * Refactor from `Control.Monad.*` to `Control.Monad.Trans.*` + + * Put classes (`MonadMulti*`) into separate modules + + * Add Strict and Lazy variants + + * Deprecate previous modules + +## 0.3.0.0 *Januar 2015* + + * Add `MultiWriter` + + * Fixity for `(:+:)` + + * support ghc-7.10 + +## 0.2.0.0 *Januar 2015* + + * Start using DataKinds and TypeOperators to make the HList + representation more readable. The translation roughly is: + + > ~~~~ + > Null -> '[] + > Cons a Null -> '[a] + > Cons a b -> a ': b + > TNull -> HNil + > TCons a b -> a :+: b + > ~~~~ + + * Remove dependency on `tfp` package. + +## 0.1.3.2 *September 2014* + + * Add example + + * Clean up / Add dependencies + + * More documentation + +## 0.1.2 *September 2014* + + * Expose `HList` module + + * Add haddocks + +## 0.1.1 *June 2014* + + * First version published on hackage diff --git a/example/Example.hs b/example/Example.hs --- a/example/Example.hs +++ b/example/Example.hs @@ -7,13 +7,15 @@ -import Control.Monad.MultiState +import Control.Monad.Trans.MultiState import Control.Applicative ( (<$>), (<*>) ) import Control.Monad.Trans ( lift ) import Control.Monad.Writer + + {- Small example showing 1) a MultiState containing a Char and a String, @@ -24,7 +26,7 @@ -} simpleExample :: IO () -simpleExample = evalMultiStateT +simpleExample = runMultiStateTNil_ $ withMultiState 'H' -- add a Char to the state $ withMultiState "ello, World!" -- add a String to the state $ do @@ -78,7 +80,7 @@ tell $ ["account balance = " ++ show x] accountCalculation :: Writer [String] () -accountCalculation = evalMultiStateT $ do +accountCalculation = runMultiStateTNil_ $ do tell ["account calculation start"] -- we cannot use any of the account methods here, because state is empty -- logAccount diff --git a/multistate.cabal b/multistate.cabal --- a/multistate.cabal +++ b/multistate.cabal @@ -1,5 +1,5 @@ Name: multistate -Version: 0.3.0.0 +Version: 0.6.0.0 Cabal-Version: >= 1.10 Build-Type: Simple license: BSD3 @@ -11,30 +11,33 @@ Bug-reports: https://github.com/lspitzner/multistate/issues Stability: Experimental category: Control -tested-with: GHC == 7.6.3, GHC == 7.8.3, GHC == 7.8.4, GHC == 7.10.0 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 -Synopsis: like mtl's ReaderT/WriterT/StateT, but more than one contained - value/type. +Synopsis: like mtl's ReaderT / WriterT / StateT, but more than one + contained value/type. Description: - When using multiple Read/Write/State transformers in the same monad stack, + When using multiple Read\/Write\/State transformers in the same monad stack, it becomes necessary to lift the operations in order to affect a specific transformer. - Using heterogenous lists (and all kinds of GHC extensions magic), + Using heterogeneous lists (and all kinds of GHC extensions magic), this package provides transformers that remove that necessity: - MultiReaderT/MultiWriterT/MultiStateT can contain a heterogenous list of - values. + MultiReaderT\/MultiWriterT\/MultiStateT\/MultiRWST can contain a + heterogeneous list of values. . See the for a longer description. + . + The latest published version contains some breaking changes. + Please complain if this causes problems (for future consideration). +extra-source-files: + README.md + changelog.md + source-repository head type: git location: git@github.com:lspitzner/multistate.git -flag build-test - description: Build the MultiState-test test program - default: False - flag build-example description: Build the MultiState-example example program default: False @@ -44,14 +47,31 @@ Haskell2010 exposed-modules: Data.HList.HList + Data.HList.ContainsType Control.Monad.MultiState Control.Monad.MultiReader Control.Monad.MultiWriter + Control.Monad.Trans.MultiReader + Control.Monad.Trans.MultiReader.Class + Control.Monad.Trans.MultiReader.Lazy + Control.Monad.Trans.MultiReader.Strict + Control.Monad.Trans.MultiWriter + Control.Monad.Trans.MultiWriter.Class + Control.Monad.Trans.MultiWriter.Lazy + Control.Monad.Trans.MultiWriter.Strict + Control.Monad.Trans.MultiState + Control.Monad.Trans.MultiState.Class + Control.Monad.Trans.MultiState.Lazy + Control.Monad.Trans.MultiState.Strict + Control.Monad.Trans.MultiRWS + Control.Monad.Trans.MultiRWS.Lazy + Control.Monad.Trans.MultiRWS.Strict other-modules: build-depends: base >= 4.6 && <4.9, mtl >= 2.1 && <2.3, - transformers >= 0.3 && <0.5 + transformers >= 0.3 && <0.5, + tagged >= 0.7 && <0.9 default-extensions: GADTs TypeFamilies @@ -66,23 +86,20 @@ hs-source-dirs: src } -executable multistate-test { - default-language: - Haskell2010 - if flag(build-test) { - buildable: True - build-depends: - -- no version constraints necessary, because they are already - -- given by library - multistate, - base, - transformers - } else { - buildable: False - } - ghc-options: -Wall - main-is: Test.hs - hs-source-dirs: test +test-suite multistate-test { + type: exitcode-stdio-1.0 + default-language: Haskell2010 + buildable: True + build-depends: + -- no version constraints necessary, because they are already + -- given by library + multistate, + base, + transformers, + hspec + ghc-options: -Wall + main-is: Test.hs + hs-source-dirs: test } executable multistate-example { diff --git a/src/Control/Monad/MultiReader.hs b/src/Control/Monad/MultiReader.hs --- a/src/Control/Monad/MultiReader.hs +++ b/src/Control/Monad/MultiReader.hs @@ -1,225 +1,34 @@ -- | The multi-valued version of mtl's Reader / ReaderT -- / MonadReader -module Control.Monad.MultiReader - ( -- * MultiReaderT +module Control.Monad.MultiReader {-# DEPRECATED "Use Control.Monad.Trans.MultiReader instead" #-} + ( + -- * MultiReaderT MultiReaderT(..) , MultiReaderTNull , MultiReader -- * MonadMultiReader class , MonadMultiReader(..) - -- * functions - , mAskRaw + -- * run-functions + , runMultiReaderT + , runMultiReaderT_ + , runMultiReaderTNil + , runMultiReaderTNil_ + -- * with-functions (single Reader) , withMultiReader + , withMultiReader_ + -- * with-functions (multiple Readers) , withMultiReaders - , evalMultiReaderT - , evalMultiReaderTWithInitial + , withMultiReaders_ + -- * inflate-function (run ReaderT in MultiReaderT) + , inflateReader + -- * other functions , mapMultiReaderT + , mGetRaw + , mPutRaw ) where -import Data.HList.HList - -import Control.Monad.State.Strict ( StateT(..) - , MonadState(..) - , evalStateT - , mapStateT ) -import Control.Monad.Trans.Class ( MonadTrans - , lift ) -import Control.Monad.Writer.Class ( MonadWriter - , listen - , tell - , writer - , pass ) - -import Data.Functor.Identity ( Identity ) - -import Control.Applicative ( Applicative(..) ) -import Control.Monad ( liftM - , ap ) - - - --- | A Reader transformer monad patameterized by: --- --- * x - The list of types constituting the environment / input (to be read), --- * m - The inner monad. --- --- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain --- a heterogenous list of types. --- --- This heterogenous list is represented using Types.Data.List, i.e: --- --- * @'[]@ - The empty list, --- * @a ': b@ - A list where @/a/@ is an arbitrary type --- and @/b/@ is the rest list. --- --- For example, --- --- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *) --- --- is a Reader transformer containing the types [Int, Bool]. -newtype MultiReaderT x m a = MultiReaderT { - runMultiReaderTRaw :: StateT (HList x) m a -} - --- | A MultiReader transformer carrying an empty state. -type MultiReaderTNull = MultiReaderT '[] - --- | A reader monad parameterized by the list of types x of the environment --- / input to carry. --- --- Similar to @Reader r = ReaderT r Identity@ -type MultiReader x = MultiReaderT x Identity - -class ContainsType a c where - setHListElem :: a -> HList c -> HList c - getHListElem :: HList c -> a - --- | All methods must be defined. --- --- The idea is: Any monad stack is instance of @MonadMultiReader a@, iff --- the stack contains a @MultiReaderT x@ with /a/ element of /x/. -class (Monad m) => MonadMultiReader a m where - mAsk :: m a -- ^ Access to a specific type in the environment. - -{- -it might make seem straightforward to define the following class that -corresponds to other transformer classes. But while we can define the the -class and its instances, there is a problem we try to use it, assuming that we -do not want to annotate the full type signature of the config: - the type of the config can not be inferred properly. we would need a feature - like "infer, as return type for this function, the only type for - which there exists a valid chain of instance definitions that is needed to - by this function". - In other words, it is impossible to use the mAskRaw function without - binding a concrete type for c, because otherwise the inference runs into - some overlapping instances. -For this reason, I removed this type class and created a non-class function -mAskRaw, for which the type inference works because it involves no -type classes. - lennart spitzner --} - ---class (Monad m) => MonadMultiReaderRaw c m where --- mAskRaw :: m (HList c) - ---instance (MonadTrans t, Monad (t m), MonadMultiReaderRaw c m) --- => MonadMultiReaderRaw c (t m) where --- mAskRaw = lift $ mAskRaw - ---instance (Monad m) => MonadMultiReaderRaw a (MultiReaderT a m) where --- mAskRaw = MultiReaderT $ get - -instance ContainsType a (a ': xs) where - setHListElem a (_ :+: xs) = a :+: xs - getHListElem (x :+: _) = x - -instance (ContainsType a xs) => ContainsType a (x ': xs) where - setHListElem a (x :+: xs) = x :+: setHListElem a xs - getHListElem (_ :+: xs) = getHListElem xs - -instance (Functor f) => Functor (MultiReaderT x f) where - fmap f = MultiReaderT . fmap f . runMultiReaderTRaw - -instance (Applicative m, Monad m) => Applicative (MultiReaderT x m) where - pure = MultiReaderT . pure - (<*>) = ap - -instance Monad m => Monad (MultiReaderT x m) where - return = MultiReaderT . return - k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= (runMultiReaderTRaw.f) - -instance MonadTrans (MultiReaderT x) where - lift = MultiReaderT . lift - --- | Adds an element to the environment, thereby transforming a MultiReaderT --- carrying an environment with types /(x:xs)/ to a a MultiReaderT with /xs/. --- --- Think "Execute this computation with this additional value as environment". -withMultiReader :: Monad m - => x - -> MultiReaderT (x ': xs) m a - -> MultiReaderT xs m a -withMultiReader x k = MultiReaderT $ do - s <- get - (a, _ :+: s') <- lift $ runStateT (runMultiReaderTRaw k) (x :+: s) - put s' - return a - --- | Adds a heterogenous list of elements to the environment, thereby --- transforming a MultiReaderT carrying an environment with values --- over types /xs++ys/ to a MultiReaderT over /ys/. --- --- Similar to recursively adding single values with 'withMultiReader'. --- --- Note that /ys/ can be Null; in that case the return value can be --- evaluated further using 'evalMultiReaderT'. -withMultiReaders :: Monad m - => HList xs - -> MultiReaderT (Append xs ys) m a - -> MultiReaderT ys m a -withMultiReaders HNil = id -withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x - -instance (Monad m, ContainsType a c) - => MonadMultiReader a (MultiReaderT c m) where - mAsk = MultiReaderT $ liftM getHListElem get - -instance (MonadTrans t, Monad (t m), MonadMultiReader a m) - => MonadMultiReader a (t m) where - mAsk = lift $ mAsk - --- | A raw extractor of the contained HList (i.e. the complete environment). --- --- For a possible usecase, see 'withMultiReaders'. -mAskRaw :: Monad m => MultiReaderT a m (HList a) -mAskRaw = MultiReaderT get - --- | Evaluate a computation over an empty environment. --- --- Because the environment is empty, it does not need to be provided. --- --- If you want to evaluate a computation over any non-Null environment, either --- use --- --- * 'evalMultiReaderTWithInitial' --- * simplify the computation using 'withMultiReader' / 'withMultiReaders', --- then use 'evalMultiReaderT' on the result. -evalMultiReaderT :: Monad m => MultiReaderT '[] m a -> m a -evalMultiReaderT k = evalStateT (runMultiReaderTRaw k) HNil - --- | Evaluate a reader computation with the given environment. -evalMultiReaderTWithInitial :: Monad m - => HList a -- ^ The initial state - -> MultiReaderT a m b -- ^ The computation to evaluate - -> m b -evalMultiReaderTWithInitial c k = evalStateT (runMultiReaderTRaw k) c - --- | Map both the return value and the environment of a computation --- using the given function. --- --- Note that there is a difference to mtl's ReaderT, --- where it is /not/ possible to modify the environment. -mapMultiReaderT :: (m (a, HList w) - -> m' (a', HList w)) - -> MultiReaderT w m a - -> MultiReaderT w m' a' -mapMultiReaderT f = MultiReaderT . mapStateT f . runMultiReaderTRaw - --- foreign lifting instances - -instance (MonadState s m) => MonadState s (MultiReaderT c m) where - put = lift . put - get = lift $ get - state = lift . state - -instance (MonadWriter w m) => MonadWriter w (MultiReaderT c m) where - writer = lift . writer - tell = lift . tell - listen = MultiReaderT . - mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . - runMultiReaderTRaw - pass = MultiReaderT . - mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . - runMultiReaderTRaw +-- just re-export +import Control.Monad.Trans.MultiReader.Class +import Control.Monad.Trans.MultiReader.Lazy diff --git a/src/Control/Monad/MultiState.hs b/src/Control/Monad/MultiState.hs --- a/src/Control/Monad/MultiState.hs +++ b/src/Control/Monad/MultiState.hs @@ -1,6 +1,6 @@ -- | The multi-valued version of mtl's State / StateT -- / MonadState -module Control.Monad.MultiState +module Control.Monad.MultiState {-# DEPRECATED "Use Control.Monad.Trans.MultiState instead" #-} ( -- * MultiStateT MultiStateT(..) @@ -8,199 +8,41 @@ , MultiState -- * MonadMultiState class , MonadMultiState(..) - -- * functions - , mGetRaw + -- * run-functions + , runMultiStateT + , runMultiStateTAS + , runMultiStateTSA + , runMultiStateTA + , runMultiStateTS + , runMultiStateT_ + , runMultiStateTNil + , runMultiStateTNil_ + -- * with-functions (single state) , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + -- * with-functions (multiple states) , withMultiStates - , evalMultiStateT - , evalMultiStateTWithInitial + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run single state in multiple states) + , inflateState + , inflateReader + , inflateWriter + -- * other functions , mapMultiStateT + , mGetRaw + , mPutRaw ) where -import Data.HList.HList - -import Control.Monad.State.Strict ( StateT(..) - , MonadState(..) - , evalStateT - , mapStateT ) -import Control.Monad.Trans.Class ( MonadTrans - , lift ) -import Control.Monad.Writer.Class ( MonadWriter - , listen - , tell - , writer - , pass ) - -import Data.Functor.Identity ( Identity ) - -import Control.Applicative ( Applicative(..) ) -import Control.Monad ( liftM - , ap ) - - - --- | A State transformer monad patameterized by: --- --- * x - The list of types constituting the state, --- * m - The inner monad. --- --- 'MultiStateT' corresponds to mtl's 'StateT', but can contain --- a heterogenous list of types. --- --- This heterogenous list is represented using Types.Data.List, i.e: --- --- * @'[]@ - The empty list, --- * @a ': b@ - A list where @/a/@ is an arbitrary type --- and @/b/@ is the rest list. --- --- For example, --- --- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *) --- --- is a State wrapper containing the types [Int, Bool]. -newtype MultiStateT x m a = MultiStateT { - runMultiStateTRaw :: StateT (HList x) m a -} - --- | A MultiState transformer carrying an empty state. -type MultiStateTNull = MultiStateT '[] - --- | A state monad parameterized by the list of types x of the state to carry. --- --- Similar to @State s = StateT s Identity@ -type MultiState x = MultiStateT x Identity - -class ContainsType a c where - setHListElem :: a -> HList c -> HList c - getHListElem :: HList c -> a - --- | All methods must be defined. --- --- The idea is: Any monad stack is instance of @MonadMultiState a@, iff --- the stack contains a @MultiStateT x@ with /a/ element of /x/. -class (Monad m) => MonadMultiState a m where - -- | state set function for values of type @a@. - mSet :: a -> m () - -- | state get function for values of type @a@. - mGet :: m a - -instance ContainsType a (a ': xs) where - setHListElem a (_ :+: xs) = a :+: xs - getHListElem (x :+: _) = x - -instance (ContainsType a xs) => ContainsType a (x ': xs) where - setHListElem a (x :+: xs) = x :+: setHListElem a xs - getHListElem (_ :+: xs) = getHListElem xs - -instance (Functor f) => Functor (MultiStateT x f) where - fmap f = MultiStateT . fmap f . runMultiStateTRaw - -instance (Applicative m, Monad m) => Applicative (MultiStateT x m) where - pure = MultiStateT . pure - (<*>) = ap - -instance Monad m => Monad (MultiStateT x m) where - return = MultiStateT . return - k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) - -instance MonadTrans (MultiStateT x) where - lift = MultiStateT . lift - --- | Adds an element to the state, thereby transforming a MultiStateT over --- values with types /(x:xs)/ to a MultiStateT over /xs/. --- --- Think "Execute this computation with this additional value as state". -withMultiState :: Monad m - => x -- ^ The value to add - -> MultiStateT (x ': xs) m a -- ^ The computation using the - -- enlarged state - -> MultiStateT xs m a -- ^ An computation using the - -- smaller state -withMultiState x k = MultiStateT $ do - s <- get - (a, _ :+: s') <- lift $ runStateT (runMultiStateTRaw k) (x :+: s) - put s' - return a - --- | Adds a heterogenous list of elements to the state, thereby --- transforming a MultiStateT over values with types /xs++ys/ to a MultiStateT --- over /ys/. --- --- Similar to recursively adding single values with 'withMultiState'. --- --- Note that /ys/ can be Null; in that case the return value can be --- evaluated further using 'evalMultiStateT'. -withMultiStates :: Monad m - => HList xs -- ^ The list of values to add - -> MultiStateT (Append xs ys) m a -- ^ The computation using the - -- enlarged state - -> MultiStateT ys m a -- ^ A computation using the - -- smaller state -withMultiStates HNil = id -withMultiStates (x :+: xs) = withMultiStates xs . withMultiState x - -instance (Monad m, ContainsType a c) - => MonadMultiState a (MultiStateT c m) where - mSet v = MultiStateT $ get >>= (put . setHListElem v) - mGet = MultiStateT $ liftM getHListElem get - -instance (MonadTrans t, Monad (t m), MonadMultiState a m) - => MonadMultiState a (t m) where - mSet = lift . mSet - mGet = lift $ mGet - --- | Evaluate an empty state computation. --- --- Because the state is empty, no initial state must be provided. --- --- Currently it is not directly possible to extract the final state of a --- computation (similar to @execStateT@ and @runStateT@ for mtl's StateT), --- but you can use 'mGetRaw' if you need such functionality. --- --- If you want to evaluate a computation over any non-Null state, either --- use --- --- * 'evalMultiStateTWithInitial' --- * simplify the computation using 'withMultiState' / 'withMultiStates', --- then use 'evalMultiStateT' on the result. -evalMultiStateT :: Monad m => MultiStateT '[] m a -> m a -evalMultiStateT k = evalStateT (runMultiStateTRaw k) HNil - --- | Evaluate a state computation with the given initial state. -evalMultiStateTWithInitial :: Monad m - => HList a -- ^ The initial state - -> MultiStateT a m b -- ^ The computation to evaluate - -> m b -evalMultiStateTWithInitial c k = evalStateT (runMultiStateTRaw k) c - --- | A raw extractor of the contained HList (i.e. the complete state). --- --- For a possible usecase, see 'withMultiStates'. -mGetRaw :: Monad m => MultiStateT a m (HList a) -mGetRaw = MultiStateT get - --- | Map both the return value and the state of a computation --- using the given function. -mapMultiStateT :: (m (a, HList w) -> m' (a', HList w)) - -> MultiStateT w m a - -> MultiStateT w m' a' -mapMultiStateT f = MultiStateT . mapStateT f . runMultiStateTRaw - --- foreign lifting instances - -instance (MonadState s m) => MonadState s (MultiStateT c m) where - put = lift . put - get = lift $ get - state = lift . state - -instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where - writer = lift . writer - tell = lift . tell - listen = MultiStateT . - mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . - runMultiStateTRaw - pass = MultiStateT . - mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . - runMultiStateTRaw +-- just re-export +import Control.Monad.Trans.MultiState.Class +import Control.Monad.Trans.MultiState.Lazy diff --git a/src/Control/Monad/MultiWriter.hs b/src/Control/Monad/MultiWriter.hs --- a/src/Control/Monad/MultiWriter.hs +++ b/src/Control/Monad/MultiWriter.hs @@ -2,159 +2,43 @@ -- | The multi-valued version of mtl's Writer / WriterT -- / MonadWriter -module Control.Monad.MultiWriter +module Control.Monad.MultiWriter {-# DEPRECATED "Use Control.Monad.Trans.MultiWriter instead" #-} ( -- * MultiWriterT MultiWriterT(..) , MultiWriterTNull , MultiWriter -- * MonadMultiWriter class , MonadMultiWriter(..) - -- * functions - , mGetRaw + -- * run-functions + , runMultiWriterT + , runMultiWriterTAW + , runMultiWriterTWA + -- , runMultiWriterTA + , runMultiWriterTW + -- , runMultiWriterT_ + , runMultiWriterTNil + , runMultiWriterTNil_ + -- * with-functions (single Writer) , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + -- * with-functions (multiple Writers) , withMultiWriters - , runMultiWriterT - , execMultiWriterT + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + -- * inflate-function (run WriterT in MultiWriterT) + , inflateWriter + -- * other functions , mapMultiWriterT -) where - -import Data.HList.HList - -import Control.Monad.State.Strict ( StateT(..) - , MonadState(..) - , execStateT - , mapStateT ) -import Control.Monad.Trans.Class ( MonadTrans - , lift ) -import Control.Monad.Writer.Class ( MonadWriter - , listen - , tell - , writer - , pass ) - -import Data.Functor.Identity ( Identity ) - -import Control.Applicative ( Applicative(..) ) -import Control.Monad ( liftM - , ap ) - -import Data.Monoid + , mGetRaw + , mPutRaw + ) +where --- | A Writer transformer monad patameterized by: --- --- * x - The list of types that can be written (Monoid instances). --- * m - The inner monad. --- --- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain --- a heterogenous list of types. --- --- This heterogenous list is represented using Types.Data.List, i.e: --- --- * @'[]@ - The empty list, --- * @a ': b@ - A list where @/a/@ is an arbitrary type --- and @/b/@ is the rest list. --- --- For example, --- --- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *) --- --- is a Writer transformer containing the types [Int, Bool]. -newtype MultiWriterT x m a = MultiWriterT { - runMultiWriterTRaw :: StateT (HList x) m a -} - --- | A MultiWriter transformer carrying an empty state. -type MultiWriterTNull = MultiWriterT '[] - -type MultiWriter x a = MultiWriterT x Identity a - -class ContainsType a c where - setHListElem :: a -> HList c -> HList c - getHListElem :: HList c -> a - -class (Monad m, Monoid a) => MonadMultiWriter a m where - mTell :: a -> m () - -instance ContainsType a (a ': xs) where - setHListElem a (_ :+: xs) = a :+: xs - getHListElem (x :+: _) = x - -instance (ContainsType a xs) => ContainsType a (x ': xs) where - setHListElem a (x :+: xs) = x :+: setHListElem a xs - getHListElem (_ :+: xs) = getHListElem xs - -instance (Functor f) => Functor (MultiWriterT x f) where - fmap f = MultiWriterT . fmap f . runMultiWriterTRaw - -instance (Applicative m, Monad m) => Applicative (MultiWriterT x m) where - pure = MultiWriterT . pure - (<*>) = ap - -instance Monad m => Monad (MultiWriterT x m) where - return = MultiWriterT . return - k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw.f) - -instance MonadTrans (MultiWriterT x) where - lift = MultiWriterT . lift - -withMultiWriter :: Monad m - => x - -> MultiWriterT (x ': xs) m a - -> MultiWriterT xs m a -withMultiWriter x k = MultiWriterT $ do - s <- get - (a, _ :+: s') <- lift $ runStateT (runMultiWriterTRaw k) (x :+: s) - put s' - return a -withMultiWriters - :: Monad m - => HList xs - -> MultiWriterT (Append xs ys) m a - -> MultiWriterT ys m a -withMultiWriters HNil = id -withMultiWriters (x :+: xs) = withMultiWriters xs . withMultiWriter x - -instance (Monad m, ContainsType a c, Monoid a) - => MonadMultiWriter a (MultiWriterT c m) where - mTell v = MultiWriterT $ do - x <- get - put $ setHListElem (getHListElem x `mappend` v) x - -instance (MonadTrans t, Monad (t m), MonadMultiWriter a m) - => MonadMultiWriter a (t m) where - mTell = lift . mTell - -runMultiWriterT :: (Monad m, Monoid (HList l)) - => MultiWriterT l m a -> m (a, HList l) -runMultiWriterT k = runStateT (runMultiWriterTRaw k) mempty - -execMultiWriterT :: (Monad m, Monoid (HList l)) - => MultiWriterT l m a -> m (HList l) -execMultiWriterT k = execStateT (runMultiWriterTRaw k) mempty - -mGetRaw :: Monad m => MultiWriterT a m (HList a) -mGetRaw = MultiWriterT get - -mapMultiWriterT :: (m (a, HList w) -> m' (a', HList w)) - -> MultiWriterT w m a - -> MultiWriterT w m' a' -mapMultiWriterT f = MultiWriterT . mapStateT f . runMultiWriterTRaw - --- foreign lifting instances - -instance (MonadState s m) => MonadState s (MultiWriterT c m) where - put = lift . put - get = lift $ get - state = lift . state - -instance (MonadWriter w m) => MonadWriter w (MultiWriterT c m) where - writer = lift . writer - tell = lift . tell - listen = MultiWriterT . - mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . - runMultiWriterTRaw - pass = MultiWriterT . - mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . - runMultiWriterTRaw +-- just re-exports +import Control.Monad.Trans.MultiWriter.Class +import Control.Monad.Trans.MultiWriter.Lazy diff --git a/src/Control/Monad/Trans/MultiRWS.hs b/src/Control/Monad/Trans/MultiRWS.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiRWS.hs @@ -0,0 +1,61 @@ +-- | The multi-valued version of mtl's RWS / RWST +module Control.Monad.Trans.MultiRWS + ( + -- * MultiRWST + MultiRWST(..) + , MultiRWSTNull + , MultiRWS + -- * run-functions (extracting from RWST) + , runMultiRWST + , runMultiRWSTASW + , runMultiRWSTW + , runMultiRWSTAW + , runMultiRWSTSW + , runMultiRWSTNil + , runMultiRWSTNil_ + -- * with-functions (extending an RWST) + , withMultiReader + , withMultiReader_ + , withMultiReaders + , withMultiReaders_ + , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + , withMultiWriters + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + , withMultiStates + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run simple transformer in MultiRWST) + , inflateReader + , inflateMultiReader + , inflateWriter + , inflateMultiWriter + , inflateState + , inflateMultiState + -- * other functions + , mapMultiRWST + , mGetRawR + , mGetRawW + , mGetRawS + , mPutRawR + , mPutRawW + , mPutRawS +) where + + + +-- just re-export +import Control.Monad.Trans.MultiRWS.Lazy diff --git a/src/Control/Monad/Trans/MultiRWS/Lazy.hs b/src/Control/Monad/Trans/MultiRWS/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiRWS/Lazy.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The multi-valued version of mtl's RWS / RWST +module Control.Monad.Trans.MultiRWS.Lazy + ( + -- * MultiRWST + MultiRWST(..) + , MultiRWSTNull + , MultiRWS + -- * run-functions (extracting from RWST) + , runMultiRWST + , runMultiRWSTASW + , runMultiRWSTW + , runMultiRWSTAW + , runMultiRWSTSW + , runMultiRWSTNil + , runMultiRWSTNil_ + -- * with-functions (extending an RWST) + , withMultiReader + , withMultiReader_ + , withMultiReaders + , withMultiReaders_ + , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + , withMultiWriters + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + , withMultiStates + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run simple transformer in MultiRWST) + , inflateReader + , inflateMultiReader + , inflateWriter + , inflateMultiWriter + , inflateState + , inflateMultiState + -- * other functions + , mapMultiRWST + , mGetRawR + , mGetRawW + , mGetRawS + , mPutRawR + , mPutRawW + , mPutRawS + ) +where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) +import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) +import Control.Monad.Trans.MultiState.Class ( MonadMultiState(..) ) +import Control.Monad.Trans.MultiReader.Lazy ( MultiReaderT(..) + , runMultiReaderT ) +import Control.Monad.Trans.MultiWriter.Lazy ( MultiWriterT(..) + , runMultiWriterT ) +import Control.Monad.Trans.MultiState.Lazy ( MultiStateT(..) + , runMultiStateT ) + +import Control.Monad.State.Lazy ( StateT(..) + , MonadState(..) + , execStateT + , evalStateT + , mapStateT ) +import Control.Monad.Reader ( ReaderT(..) ) +import Control.Monad.Writer.Lazy ( WriterT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) + +import Data.Monoid + + + +newtype MultiRWST r w s m a = MultiRWST { + runMultiRWSTRaw :: StateT (HList r, HList w, HList s) m a +} + +type MultiRWSTNull = MultiRWST '[] '[] '[] + +type MultiRWS r w s = MultiRWST r w s Identity + +instance (Functor f) => Functor (MultiRWST r w s f) where + fmap f = MultiRWST . fmap f . runMultiRWSTRaw + +instance (Applicative m, Monad m) => Applicative (MultiRWST r w s m) where + pure = MultiRWST . pure + (<*>) = ap + +instance (Monad m) => Monad (MultiRWST r w s m) where + return = MultiRWST . return + k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f + +instance MonadTrans (MultiRWST r w s) where + lift = MultiRWST . lift + +instance (Monad m, ContainsType a r) + => MonadMultiReader a (MultiRWST r w s m) where + mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get + +instance (Monad m, ContainsType a w, Monoid a) + => MonadMultiWriter a (MultiRWST r w s m) where + mTell v = MultiRWST $ do + ~(r,w,s) <- get + put $ (r, setHListElem (getHListElem w `mappend` v) w, s) + +instance (Monad m, ContainsType a s) + => MonadMultiState a (MultiRWST r w s m) where + mSet v = MultiRWST $ do + ~(r,w,s) <- get + put (r, w, setHListElem v s) + mGet = MultiRWST $ do + ~(_,_,s) <- get + return $ getHListElem s + +-- methods + +runMultiRWST :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (a, HList s, HList w) +runMultiRWSTASW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (a, HList s, HList w) +runMultiRWSTW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (HList w) +runMultiRWSTAW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (a, HList w) +runMultiRWSTSW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (HList s, HList w) + +runMultiRWSTNil :: ( Monad m ) + => MultiRWST '[] '[] '[] m a + -> m a +runMultiRWSTNil_ :: ( Monad m, Functor m ) + => MultiRWST '[] '[] '[] m a + -> m () +runMultiRWST = runMultiRWSTASW +runMultiRWSTASW r s k = do + ~(x, ~(_, w, s')) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ (x, s', w) +runMultiRWSTW r s k = do + ~(_, w, _) <- execStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ w +runMultiRWSTAW r s k = do + ~(x, ~(_, w, _)) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ (x, w) +runMultiRWSTSW r s k = do + ~(_, w, s') <- execStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ (s', w) +runMultiRWSTNil k = evalStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) +runMultiRWSTNil_ k = void $ runStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) + +withMultiReader :: Monad m => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m a +withMultiReader_ :: (Functor m, Monad m) => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m () +withMultiReaders :: Monad m => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m a +withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m () +withMultiReader x k = MultiRWST $ do + (r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (x :+: r, w, s) + put (r, w', s') + return a +withMultiReader_ x k = MultiRWST $ do + (r, w, s) <- get + ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (x :+: r, w, s) + put (r, w', s') +withMultiReaders HNil = id +withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x +withMultiReaders_ HNil = void +withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader x + +withMultiWriter :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) +withMultiWriterAW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) +withMultiWriterWA :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (w, a) +withMultiWriterW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m w +withMultiWriters :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (a, HList w1) +withMultiWritersAW :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (a, HList w1) +withMultiWritersWA :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (HList w1, a) +withMultiWritersW :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (HList w1) +withMultiWriter = withMultiWriterAW +withMultiWriterAW k = MultiRWST $ do + (r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) + case w' of + x' :+: wr' -> do + put (r, wr', s') + return (a, x') +withMultiWriterWA k = MultiRWST $ do + (r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) + case w' of + x' :+: wr' -> do + put (r, wr', s') + return (x', a) +withMultiWriterW k = MultiRWST $ do + (r, w, s) <- get + ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) + case w' of + x' :+: wr' -> do + put (r, wr', s') + return x' +withMultiWriters = withMultiWritersAW +withMultiWritersAW k = MultiRWST $ do + (r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) + let (o, wr') = hSplit w' + put (r, wr', s') + return (a, o) +withMultiWritersWA k = MultiRWST $ do + (r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) + let (o, wr') = hSplit w' + put (r, wr', s') + return (o, a) +withMultiWritersW k = MultiRWST $ do + (r, w, s) <- get + ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) + let (o, wr') = hSplit w' + put (r, wr', s') + return o + +withMultiState :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) +withMultiStateAS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) +withMultiStateSA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (s, a) +withMultiStateA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m a +withMultiStateS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m s +withMultiState_ :: (Functor m, Monad m) => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m () +withMultiStates :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) +withMultiStatesAS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) +withMultiStatesSA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1, a) +withMultiStatesA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m a +withMultiStatesS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1) +withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m () +withMultiState = withMultiStateAS +withMultiStateAS x k = MultiRWST $ do + ~(r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + x' :+: sr' -> do + put (r, w', sr') + return (a, x') +withMultiStateSA x k = MultiRWST $ do + ~(r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + x' :+: sr' -> do + put (r, w', sr') + return (x', a) +withMultiStateA x k = MultiRWST $ do + ~(r, w, s) <- get + ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + _ :+: sr' -> do + put (r, w', sr') + return a +withMultiStateS x k = MultiRWST $ do + ~(r, w, s) <- get + ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + x' :+: sr' -> do + put (r, w', sr') + return x' +withMultiState_ x k = MultiRWST $ do + ~(r, w, s) <- get + ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of _ :+: sr' -> put (r, w', sr') +withMultiStates = withMultiStatesAS +withMultiStatesAS HNil k = do a <- k; return (a, HNil) +withMultiStatesAS (x :+: xs) k = do + ~(~(a, x'), xs') <- withMultiStates xs $ withMultiState x k + return (a, x' :+: xs') +withMultiStatesSA HNil k = do a <- k; return (HNil, a) +withMultiStatesSA (x :+: xs) k = do + ~(~(a, x'), xs') <- withMultiStates xs $ withMultiState x k + return (x' :+: xs', a) +withMultiStatesA HNil = id +withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x +withMultiStatesS HNil k = k >> return HNil +withMultiStatesS (x :+: xs) k = do + ~(x', xs') <- withMultiStates xs $ withMultiStateS x k + return (x' :+: xs') +withMultiStates_ HNil = void +withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x + +inflateReader :: (Monad m, ContainsType r rs) + => ReaderT r m a + -> MultiRWST rs w s m a +inflateReader k = mAsk >>= lift . runReaderT k +inflateMultiReader :: Monad m => MultiReaderT r m a -> MultiRWST r w s m a +inflateMultiReader k = do + r <- mGetRawR + lift $ runMultiReaderT r k +inflateWriter :: (Monad m, ContainsType w ws, Monoid w) + => WriterT w m a + -> MultiRWST r ws s m a +inflateWriter k = do + ~(x, w) <- lift $ runWriterT k + mTell w + return x +inflateMultiWriter :: (Functor m, Monad m, Monoid (HList w)) + => MultiWriterT w m a + -> MultiRWST r w s m a +inflateMultiWriter k = do + ~(x, w) <- lift $ runMultiWriterT k + mPutRawW w + return x +inflateState :: (Monad m, ContainsType s ss) + => StateT s m a + -> MultiRWST r w ss m a +inflateState k = do + s <- mGet + ~(x, s') <- lift $ runStateT k s + mSet s' + return x +inflateMultiState :: (Functor m, Monad m) + => MultiStateT s m a + -> MultiRWST r w s m a +inflateMultiState k = do + s <- mGetRawS + ~(x, s') <- lift $ runMultiStateT s k + mPutRawS s' + return x + +mGetRawR :: Monad m => MultiRWST r w s m (HList r) +mPutRawR :: Monad m => HList r -> MultiRWST r w s m () +mGetRawW :: Monad m => MultiRWST r w s m (HList w) +mPutRawW :: Monad m => HList w -> MultiRWST r w s m () +mGetRawS :: Monad m => MultiRWST r w s m (HList s) +mPutRawS :: Monad m => HList s -> MultiRWST r w s m () +mGetRawR = (\(r, _, _) -> r) `liftM` MultiRWST get +mPutRawR r = MultiRWST $ do + ~(_, w, s) <- get + put (r, w, s) +mGetRawW = (\(_, w, _) -> w) `liftM` MultiRWST get +mPutRawW w = MultiRWST $ do + ~(r, _, s) <- get + put (r, w, s) +mGetRawS = (\(_, _, s) -> s) `liftM` MultiRWST get +mPutRawS s = MultiRWST $ do + ~(r, w, _) <- get + put (r, w, s) + +mapMultiRWST :: (ss ~ (HList r, HList w, HList s)) + => (m (a, ss) -> m' (a', ss)) + -> MultiRWST r w s m a + -> MultiRWST r w s m' a' +mapMultiRWST f = MultiRWST . mapStateT f . runMultiRWSTRaw diff --git a/src/Control/Monad/Trans/MultiRWS/Strict.hs b/src/Control/Monad/Trans/MultiRWS/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiRWS/Strict.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The multi-valued version of mtl's RWS / RWST +module Control.Monad.Trans.MultiRWS.Strict + ( + -- * MultiRWST + MultiRWST(..) + , MultiRWSTNull + , MultiRWS + -- * run-functions (extracting from RWST) + , runMultiRWST + , runMultiRWSTASW + , runMultiRWSTW + , runMultiRWSTAW + , runMultiRWSTSW + , runMultiRWSTNil + , runMultiRWSTNil_ + -- * with-functions (extending an RWST) + , withMultiReader + , withMultiReader_ + , withMultiReaders + , withMultiReaders_ + , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + , withMultiWriters + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + , withMultiStates + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run simple transformer in MultiRWST) + , inflateReader + , inflateMultiReader + , inflateWriter + , inflateMultiWriter + , inflateState + , inflateMultiState + -- * other functions + , mapMultiRWST + , mGetRawR + , mGetRawW + , mGetRawS + , mPutRawR + , mPutRawW + , mPutRawS + ) +where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) +import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) +import Control.Monad.Trans.MultiState.Class ( MonadMultiState(..) ) +import Control.Monad.Trans.MultiReader.Strict ( MultiReaderT(..) + , runMultiReaderT ) +import Control.Monad.Trans.MultiWriter.Strict ( MultiWriterT(..) + , runMultiWriterT ) +import Control.Monad.Trans.MultiState.Strict ( MultiStateT(..) + , runMultiStateT ) + +import Control.Monad.State.Strict ( StateT(..) + , MonadState(..) + , execStateT + , evalStateT + , mapStateT ) +import Control.Monad.Reader ( ReaderT(..) ) +import Control.Monad.Writer.Strict ( WriterT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) + +import Data.Monoid + + + +newtype MultiRWST r w s m a = MultiRWST { + runMultiRWSTRaw :: StateT (HList r, HList w, HList s) m a +} + +type MultiRWSTNull = MultiRWST '[] '[] '[] + +type MultiRWS r w s = MultiRWST r w s Identity + +instance (Functor f) => Functor (MultiRWST r w s f) where + fmap f = MultiRWST . fmap f . runMultiRWSTRaw + +instance (Applicative m, Monad m) => Applicative (MultiRWST r w s m) where + pure = MultiRWST . pure + (<*>) = ap + +instance (Monad m) => Monad (MultiRWST r w s m) where + return = MultiRWST . return + k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f + +instance MonadTrans (MultiRWST r w s) where + lift = MultiRWST . lift + +instance (Monad m, ContainsType a r) + => MonadMultiReader a (MultiRWST r w s m) where + mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get + +instance (Monad m, ContainsType a w, Monoid a) + => MonadMultiWriter a (MultiRWST r w s m) where + mTell v = MultiRWST $ do + (r,w,s) <- get + put $ (r, setHListElem (getHListElem w `mappend` v) w, s) + +instance (Monad m, ContainsType a s) + => MonadMultiState a (MultiRWST r w s m) where + mSet v = MultiRWST $ do + (r,w,s) <- get + put (r, w, setHListElem v s) + mGet = MultiRWST $ do + (_,_,s) <- get + return $ getHListElem s + +-- methods + +runMultiRWST :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (a, HList s, HList w) +runMultiRWSTASW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (a, HList s, HList w) +runMultiRWSTW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (HList w) +runMultiRWSTAW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (a, HList w) +runMultiRWSTSW :: ( Monad m + , Monoid (HList w) + ) + => HList r + -> HList s + -> MultiRWST r w s m a + -> m (HList s, HList w) + +runMultiRWSTNil :: ( Monad m ) + => MultiRWST '[] '[] '[] m a + -> m a +runMultiRWSTNil_ :: ( Monad m, Functor m ) + => MultiRWST '[] '[] '[] m a + -> m () +runMultiRWST = runMultiRWSTASW +runMultiRWSTASW r s k = do + (x, (_, w, s')) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ (x, s', w) +runMultiRWSTW r s k = do + (_, w, _) <- execStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ w +runMultiRWSTAW r s k = do + (x, (_, w, _)) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ (x, w) +runMultiRWSTSW r s k = do + (_, w, s') <- execStateT (runMultiRWSTRaw k) (r, mempty, s) + return $ (s', w) +runMultiRWSTNil k = evalStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) +runMultiRWSTNil_ k = void $ runStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) + +withMultiReader :: Monad m => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m a +withMultiReader_ :: (Functor m, Monad m) => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m () +withMultiReaders :: Monad m => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m a +withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m () +withMultiReader x k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (x :+: r, w, s) + put (r, w', s') + return a +withMultiReader_ x k = MultiRWST $ do + (r, w, s) <- get + (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (x :+: r, w, s) + put (r, w', s') +withMultiReaders HNil = id +withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x +withMultiReaders_ HNil = void +withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader x + +withMultiWriter :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) +withMultiWriterAW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) +withMultiWriterWA :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (w, a) +withMultiWriterW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m w +withMultiWriters :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (a, HList w1) +withMultiWritersAW :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (a, HList w1) +withMultiWritersWA :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (HList w1, a) +withMultiWritersW :: forall r w1 w2 s m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiRWST r (Append w1 w2) s m a + -> MultiRWST r w2 s m (HList w1) +withMultiWriter = withMultiWriterAW +withMultiWriterAW k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) + case w' of + x' :+: wr' -> do + put (r, wr', s') + return (a, x') +withMultiWriterWA k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) + case w' of + x' :+: wr' -> do + put (r, wr', s') + return (x', a) +withMultiWriterW k = MultiRWST $ do + (r, w, s) <- get + (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) + case w' of + x' :+: wr' -> do + put (r, wr', s') + return x' +withMultiWriters = withMultiWritersAW +withMultiWritersAW k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) + let (o, wr') = hSplit w' + put (r, wr', s') + return (a, o) +withMultiWritersWA k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) + let (o, wr') = hSplit w' + put (r, wr', s') + return (o, a) +withMultiWritersW k = MultiRWST $ do + (r, w, s) <- get + (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) + let (o, wr') = hSplit w' + put (r, wr', s') + return o + +withMultiState :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) +withMultiStateAS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) +withMultiStateSA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (s, a) +withMultiStateA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m a +withMultiStateS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m s +withMultiState_ :: (Functor m, Monad m) => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m () +withMultiStates :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) +withMultiStatesAS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) +withMultiStatesSA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1, a) +withMultiStatesA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m a +withMultiStatesS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1) +withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m () +withMultiState = withMultiStateAS +withMultiStateAS x k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + x' :+: sr' -> do + put (r, w', sr') + return (a, x') +withMultiStateSA x k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + x' :+: sr' -> do + put (r, w', sr') + return (x', a) +withMultiStateA x k = MultiRWST $ do + (r, w, s) <- get + (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + _ :+: sr' -> do + put (r, w', sr') + return a +withMultiStateS x k = MultiRWST $ do + (r, w, s) <- get + (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of + x' :+: sr' -> do + put (r, w', sr') + return x' +withMultiState_ x k = MultiRWST $ do + (r, w, s) <- get + (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) + case s' of _ :+: sr' -> put (r, w', sr') +withMultiStates = withMultiStatesAS +withMultiStatesAS HNil k = do a <- k; return (a, HNil) +withMultiStatesAS (x :+: xs) k = do + ((a, x'), xs') <- withMultiStates xs $ withMultiState x k + return (a, x' :+: xs') +withMultiStatesSA HNil k = do a <- k; return (HNil, a) +withMultiStatesSA (x :+: xs) k = do + ((a, x'), xs') <- withMultiStates xs $ withMultiState x k + return (x' :+: xs', a) +withMultiStatesA HNil = id +withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x +withMultiStatesS HNil k = k >> return HNil +withMultiStatesS (x :+: xs) k = do + (x', xs') <- withMultiStates xs $ withMultiStateS x k + return (x' :+: xs') +withMultiStates_ HNil = void +withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x + +inflateReader :: (Monad m, ContainsType r rs) + => ReaderT r m a + -> MultiRWST rs w s m a +inflateReader k = mAsk >>= lift . runReaderT k +inflateMultiReader :: Monad m => MultiReaderT r m a -> MultiRWST r w s m a +inflateMultiReader k = do + r <- mGetRawR + lift $ runMultiReaderT r k +inflateWriter :: (Monad m, ContainsType w ws, Monoid w) + => WriterT w m a + -> MultiRWST r ws s m a +inflateWriter k = do + (x, w) <- lift $ runWriterT k + mTell w + return x +inflateMultiWriter :: (Functor m, Monad m, Monoid (HList w)) + => MultiWriterT w m a + -> MultiRWST r w s m a +inflateMultiWriter k = do + (x, w) <- lift $ runMultiWriterT k + mPutRawW w + return x +inflateState :: (Monad m, ContainsType s ss) + => StateT s m a + -> MultiRWST r w ss m a +inflateState k = do + s <- mGet + (x, s') <- lift $ runStateT k s + mSet s' + return x +inflateMultiState :: (Functor m, Monad m) + => MultiStateT s m a + -> MultiRWST r w s m a +inflateMultiState k = do + s <- mGetRawS + (x, s') <- lift $ runMultiStateT s k + mPutRawS s' + return x + +mGetRawR :: Monad m => MultiRWST r w s m (HList r) +mPutRawR :: Monad m => HList r -> MultiRWST r w s m () +mGetRawW :: Monad m => MultiRWST r w s m (HList w) +mPutRawW :: Monad m => HList w -> MultiRWST r w s m () +mGetRawS :: Monad m => MultiRWST r w s m (HList s) +mPutRawS :: Monad m => HList s -> MultiRWST r w s m () +mGetRawR = (\(r, _, _) -> r) `liftM` MultiRWST get +mPutRawR r = MultiRWST $ do + ~(_, w, s) <- get + put (r, w, s) +mGetRawW = (\(_, w, _) -> w) `liftM` MultiRWST get +mPutRawW w = MultiRWST $ do + ~(r, _, s) <- get + put (r, w, s) +mGetRawS = (\(_, _, s) -> s) `liftM` MultiRWST get +mPutRawS s = MultiRWST $ do + ~(r, w, _) <- get + put (r, w, s) + +mapMultiRWST :: (ss ~ (HList r, HList w, HList s)) + => (m (a, ss) -> m' (a', ss)) + -> MultiRWST r w s m a + -> MultiRWST r w s m' a' +mapMultiRWST f = MultiRWST . mapStateT f . runMultiRWSTRaw diff --git a/src/Control/Monad/Trans/MultiReader.hs b/src/Control/Monad/Trans/MultiReader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiReader.hs @@ -0,0 +1,33 @@ +-- | The multi-valued version of mtl's Reader / ReaderT +-- / MonadReader +module Control.Monad.Trans.MultiReader + ( -- * MultiReaderT + MultiReaderT(..) + , MultiReaderTNull + , MultiReader + -- * MonadMultiReader class + , MonadMultiReader(..) + -- * run-functions + , runMultiReaderT + , runMultiReaderT_ + , runMultiReaderTNil + , runMultiReaderTNil_ + -- * with-functions (single Reader) + , withMultiReader + , withMultiReader_ + -- * with-functions (multiple Readers) + , withMultiReaders + , withMultiReaders_ + -- * inflate-function (run ReaderT in MultiReaderT) + , inflateReader + -- * other functions + , mapMultiReaderT + , mGetRaw + , mPutRaw +) where + + + +-- just re-export +import Control.Monad.Trans.MultiReader.Class +import Control.Monad.Trans.MultiReader.Lazy diff --git a/src/Control/Monad/Trans/MultiReader/Class.hs b/src/Control/Monad/Trans/MultiReader/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiReader/Class.hs @@ -0,0 +1,53 @@ +-- | The multi-valued version of mtl's MonadReader +module Control.Monad.Trans.MultiReader.Class + ( + -- * MonadMultiReader class + MonadMultiReader(..) + ) +where + + + +import Control.Monad.Trans.Class ( MonadTrans + , lift ) + + + +-- | All methods must be defined. +-- +-- The idea is: Any monad stack is instance of @MonadMultiReader a@, iff +-- the stack contains a @MultiReaderT x@ with /a/ element of /x/. +class (Monad m) => MonadMultiReader a m where + mAsk :: m a -- ^ Access to a specific type in the environment. + +instance (MonadTrans t, Monad (t m), MonadMultiReader a m) + => MonadMultiReader a (t m) where + mAsk = lift $ mAsk + +{- +it might make seem straightforward to define the following class that +corresponds to other transformer classes. But while we can define the the +class and its instances, there is a problem we try to use it, assuming that we +do not want to annotate the full type signature of the config: + the type of the config can not be inferred properly. we would need a feature + like "infer, as return type for this function, the only type for + which there exists a valid chain of instance definitions that is needed to + by this function". + In other words, it is impossible to use the mAskRaw function without + binding a concrete type for c, because otherwise the inference runs into + some overlapping instances. +For this reason, I removed this type class and created a non-class function +mAskRaw, for which the type inference works because it involves no +type classes. + lennart spitzner +-} + +--class (Monad m) => MonadMultiReaderRaw c m where +-- mAskRaw :: m (HList c) + +--instance (MonadTrans t, Monad (t m), MonadMultiReaderRaw c m) +-- => MonadMultiReaderRaw c (t m) where +-- mAskRaw = lift $ mAskRaw + +--instance (Monad m) => MonadMultiReaderRaw a (MultiReaderT a m) where +-- mAskRaw = MultiReaderT $ get diff --git a/src/Control/Monad/Trans/MultiReader/Lazy.hs b/src/Control/Monad/Trans/MultiReader/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiReader/Lazy.hs @@ -0,0 +1,175 @@ +-- | The multi-valued version of mtl's Reader / ReaderT +module Control.Monad.Trans.MultiReader.Lazy + ( + -- * MultiReaderT + MultiReaderT(..) + , MultiReaderTNull + , MultiReader + -- * run-functions + , runMultiReaderT + , runMultiReaderT_ + , runMultiReaderTNil + , runMultiReaderTNil_ + -- * with-functions (single Reader) + , withMultiReader + , withMultiReader_ + -- * with-functions (multiple Readers) + , withMultiReaders + , withMultiReaders_ + -- * inflate-function (run ReaderT in MultiReaderT) + , inflateReader + -- * other functions + , mapMultiReaderT + , mGetRaw + , mPutRaw +) where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) + +import Control.Monad.State.Lazy ( StateT(..) + , MonadState(..) + , evalStateT + , mapStateT ) +import Control.Monad.Reader ( ReaderT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Writer.Class ( MonadWriter + , listen + , tell + , writer + , pass ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) + + + +-- | A Reader transformer monad patameterized by: +-- +-- * x - The list of types constituting the environment / input (to be read), +-- * m - The inner monad. +-- +-- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain +-- a heterogenous list of types. +-- +-- This heterogenous list is represented using Types.Data.List, i.e: +-- +-- * @'[]@ - The empty list, +-- * @a ': b@ - A list where @/a/@ is an arbitrary type +-- and @/b/@ is the rest list. +-- +-- For example, +-- +-- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *) +-- +-- is a Reader transformer containing the types [Int, Bool]. +newtype MultiReaderT x m a = MultiReaderT { + runMultiReaderTRaw :: StateT (HList x) m a +} + +-- | A MultiReader transformer carrying an empty state. +type MultiReaderTNull = MultiReaderT '[] + +-- | A reader monad parameterized by the list of types x of the environment +-- / input to carry. +-- +-- Similar to @Reader r = ReaderT r Identity@ +type MultiReader x = MultiReaderT x Identity + +instance (Functor f) => Functor (MultiReaderT x f) where + fmap f = MultiReaderT . fmap f . runMultiReaderTRaw + +instance (Applicative m, Monad m) => Applicative (MultiReaderT x m) where + pure = MultiReaderT . pure + (<*>) = ap + +instance Monad m => Monad (MultiReaderT x m) where + return = MultiReaderT . return + k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= runMultiReaderTRaw . f + +instance MonadTrans (MultiReaderT x) where + lift = MultiReaderT . lift + +instance (Monad m, ContainsType a c) + => MonadMultiReader a (MultiReaderT c m) where + mAsk = MultiReaderT $ liftM getHListElem get + +-- methods + +-- | A raw extractor of the contained HList (i.e. the complete Reader). +mGetRaw :: Monad m => MultiReaderT a m (HList a) +mGetRaw = MultiReaderT get + +mPutRaw :: Monad m => HList s -> MultiReaderT s m () +mPutRaw = MultiReaderT . put + +-- | Map both the return value and the environment of a computation +-- using the given function. +-- +-- Note that there is a difference to mtl's ReaderT, +-- where it is /not/ possible to modify the environment. +mapMultiReaderT :: (m (a, HList w) -> m' (a', HList w)) + -> MultiReaderT w m a + -> MultiReaderT w m' a' +mapMultiReaderT f = MultiReaderT . mapStateT f . runMultiReaderTRaw + +runMultiReaderT :: Monad m => HList r -> MultiReaderT r m a -> m a +runMultiReaderT_ :: Functor m => HList r -> MultiReaderT r m a -> m () +-- ghc too dumb for this shortcut, unfortunately +-- runMultiReaderT s k = runMultiReaderTNil $ withMultiReaders s k +-- runMultiReaderT_ s k = runMultiReaderTNil $ withMultiReaders_ s k +runMultiReaderT s k = evalStateT (runMultiReaderTRaw k) s +runMultiReaderT_ s k = void $ runStateT (runMultiReaderTRaw k) s + +runMultiReaderTNil :: Monad m => MultiReaderT '[] m a -> m a +runMultiReaderTNil_ :: Functor m => MultiReaderT '[] m a -> m () +runMultiReaderTNil k = evalStateT (runMultiReaderTRaw k) HNil +runMultiReaderTNil_ k = void $ runStateT (runMultiReaderTRaw k) HNil + +withMultiReader :: Monad m => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m a +withMultiReader_ :: (Functor m, Monad m) => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m () +withMultiReader x k = MultiReaderT $ + get >>= lift . evalStateT (runMultiReaderTRaw k) . (x :+:) +withMultiReader_ x k = void $ withMultiReader x k + +withMultiReaders :: Monad m => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m a +withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m () +withMultiReaders HNil = id +withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x +withMultiReaders_ HNil = liftM (const ()) +withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x + +inflateReader :: (Monad m, ContainsType r rs) + => ReaderT r m a + -> MultiReaderT rs m a +inflateReader k = mAsk >>= lift . runReaderT k + +-- foreign lifting instances + +instance (MonadState s m) => MonadState s (MultiReaderT c m) where + put = lift . put + get = lift $ get + state = lift . state + +instance (MonadWriter w m) => MonadWriter w (MultiReaderT c m) where + writer = lift . writer + tell = lift . tell + listen = MultiReaderT . + mapStateT (liftM (\(~(~(a,w), w')) -> ((a, w'), w)) . listen) . + runMultiReaderTRaw + pass = MultiReaderT . + mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) . + runMultiReaderTRaw + + + + diff --git a/src/Control/Monad/Trans/MultiReader/Strict.hs b/src/Control/Monad/Trans/MultiReader/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiReader/Strict.hs @@ -0,0 +1,175 @@ +-- | The multi-valued version of mtl's Reader / ReaderT +module Control.Monad.Trans.MultiReader.Strict + ( + -- * MultiReaderT + MultiReaderT(..) + , MultiReaderTNull + , MultiReader + -- * run-functions + , runMultiReaderT + , runMultiReaderT_ + , runMultiReaderTNil + , runMultiReaderTNil_ + -- * with-functions (single Reader) + , withMultiReader + , withMultiReader_ + -- * with-functions (multiple Readers) + , withMultiReaders + , withMultiReaders_ + -- * inflate-function (run ReaderT in MultiReaderT) + , inflateReader + -- * other functions + , mapMultiReaderT + , mGetRaw + , mPutRaw +) where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) + +import Control.Monad.State.Strict ( StateT(..) + , MonadState(..) + , evalStateT + , mapStateT ) +import Control.Monad.Reader ( ReaderT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Writer.Class ( MonadWriter + , listen + , tell + , writer + , pass ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) + + + +-- | A Reader transformer monad patameterized by: +-- +-- * x - The list of types constituting the environment / input (to be read), +-- * m - The inner monad. +-- +-- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain +-- a heterogenous list of types. +-- +-- This heterogenous list is represented using Types.Data.List, i.e: +-- +-- * @'[]@ - The empty list, +-- * @a ': b@ - A list where @/a/@ is an arbitrary type +-- and @/b/@ is the rest list. +-- +-- For example, +-- +-- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *) +-- +-- is a Reader transformer containing the types [Int, Bool]. +newtype MultiReaderT x m a = MultiReaderT { + runMultiReaderTRaw :: StateT (HList x) m a +} + +-- | A MultiReader transformer carrying an empty state. +type MultiReaderTNull = MultiReaderT '[] + +-- | A reader monad parameterized by the list of types x of the environment +-- / input to carry. +-- +-- Similar to @Reader r = ReaderT r Identity@ +type MultiReader x = MultiReaderT x Identity + +instance (Functor f) => Functor (MultiReaderT x f) where + fmap f = MultiReaderT . fmap f . runMultiReaderTRaw + +instance (Applicative m, Monad m) => Applicative (MultiReaderT x m) where + pure = MultiReaderT . pure + (<*>) = ap + +instance Monad m => Monad (MultiReaderT x m) where + return = MultiReaderT . return + k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= (runMultiReaderTRaw . f) + +instance MonadTrans (MultiReaderT x) where + lift = MultiReaderT . lift + +instance (Monad m, ContainsType a c) + => MonadMultiReader a (MultiReaderT c m) where + mAsk = MultiReaderT $ liftM getHListElem get + +-- methods + +-- | A raw extractor of the contained HList (i.e. the complete Reader). +mGetRaw :: Monad m => MultiReaderT a m (HList a) +mGetRaw = MultiReaderT get + +mPutRaw :: Monad m => HList s -> MultiReaderT s m () +mPutRaw = MultiReaderT . put + +-- | Map both the return value and the environment of a computation +-- using the given function. +-- +-- Note that there is a difference to mtl's ReaderT, +-- where it is /not/ possible to modify the environment. +mapMultiReaderT :: (m (a, HList w) -> m' (a', HList w)) + -> MultiReaderT w m a + -> MultiReaderT w m' a' +mapMultiReaderT f = MultiReaderT . mapStateT f . runMultiReaderTRaw + +runMultiReaderT :: Monad m => HList r -> MultiReaderT r m a -> m a +runMultiReaderT_ :: Functor m => HList r -> MultiReaderT r m a -> m () +-- ghc too dumb for this shortcut, unfortunately +-- runMultiReaderT s k = runMultiReaderTNil $ withMultiReaders s k +-- runMultiReaderT_ s k = runMultiReaderTNil $ withMultiReaders_ s k +runMultiReaderT s k = evalStateT (runMultiReaderTRaw k) s +runMultiReaderT_ s k = void $ runStateT (runMultiReaderTRaw k) s + +runMultiReaderTNil :: Monad m => MultiReaderT '[] m a -> m a +runMultiReaderTNil_ :: Functor m => MultiReaderT '[] m a -> m () +runMultiReaderTNil k = evalStateT (runMultiReaderTRaw k) HNil +runMultiReaderTNil_ k = void $ runStateT (runMultiReaderTRaw k) HNil + +withMultiReader :: Monad m => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m a +withMultiReader_ :: (Functor m, Monad m) => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m () +withMultiReader x k = MultiReaderT $ + get >>= lift . evalStateT (runMultiReaderTRaw k) . (x :+:) +withMultiReader_ x k = void $ withMultiReader x k + +withMultiReaders :: Monad m => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m a +withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m () +withMultiReaders HNil = id +withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x +withMultiReaders_ HNil = liftM (const ()) +withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x + +inflateReader :: (Monad m, ContainsType r rs) + => ReaderT r m a + -> MultiReaderT rs m a +inflateReader k = mAsk >>= lift . runReaderT k + +-- foreign lifting instances + +instance (MonadState s m) => MonadState s (MultiReaderT c m) where + put = lift . put + get = lift $ get + state = lift . state + +instance (MonadWriter w m) => MonadWriter w (MultiReaderT c m) where + writer = lift . writer + tell = lift . tell + listen = MultiReaderT . + mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . + runMultiReaderTRaw + pass = MultiReaderT . + mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . + runMultiReaderTRaw + + + + diff --git a/src/Control/Monad/Trans/MultiState.hs b/src/Control/Monad/Trans/MultiState.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiState.hs @@ -0,0 +1,48 @@ +-- | The multi-valued version of mtl's State / StateT +-- / MonadState +module Control.Monad.Trans.MultiState + ( + -- * MultiStateT + MultiStateT(..) + , MultiStateTNull + , MultiState + -- * MonadMultiState class + , MonadMultiState(..) + -- * run-functions + , runMultiStateT + , runMultiStateTAS + , runMultiStateTSA + , runMultiStateTA + , runMultiStateTS + , runMultiStateT_ + , runMultiStateTNil + , runMultiStateTNil_ + -- * with-functions (single state) + , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + -- * with-functions (multiple states) + , withMultiStates + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run single state in multiple states) + , inflateState + , inflateReader + , inflateWriter + -- * other functions + , mapMultiStateT + , mGetRaw + , mPutRaw +) where + + + +-- just re-export +import Control.Monad.Trans.MultiState.Class +import Control.Monad.Trans.MultiState.Lazy diff --git a/src/Control/Monad/Trans/MultiState/Class.hs b/src/Control/Monad/Trans/MultiState/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiState/Class.hs @@ -0,0 +1,29 @@ +-- | The multi-valued version of mtl's MonadState +module Control.Monad.Trans.MultiState.Class + ( + -- * MonadMultiState class + MonadMultiState(..) + ) +where + + + +import Control.Monad.Trans.Class ( MonadTrans + , lift ) + + + +-- | All methods must be defined. +-- +-- The idea is: Any monad stack is instance of @MonadMultiState a@, iff +-- the stack contains a @MultiStateT x@ with /a/ element of /x/. +class (Monad m) => MonadMultiState a m where + -- | state set function for values of type @a@. + mSet :: a -> m () + -- | state get function for values of type @a@. + mGet :: m a + +instance (MonadTrans t, Monad (t m), MonadMultiState a m) + => MonadMultiState a (t m) where + mSet = lift . mSet + mGet = lift $ mGet diff --git a/src/Control/Monad/Trans/MultiState/Lazy.hs b/src/Control/Monad/Trans/MultiState/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiState/Lazy.hs @@ -0,0 +1,245 @@ +-- | The multi-valued version of mtl's State / StateT +module Control.Monad.Trans.MultiState.Lazy + ( + -- * MultiStateT + MultiStateT(..) + , MultiStateTNull + , MultiState + -- * MonadMultiState class + , MonadMultiState(..) + -- * run-functions + , runMultiStateT + , runMultiStateTAS + , runMultiStateTSA + , runMultiStateTA + , runMultiStateTS + , runMultiStateT_ + , runMultiStateTNil + , runMultiStateTNil_ + -- * with-functions (single state) + , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + -- * with-functions (multiple states) + , withMultiStates + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run single state in multiple states) + , inflateState + , inflateReader + , inflateWriter + -- * other functions + , mapMultiStateT + , mGetRaw + , mPutRaw +) where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiState.Class + +import Control.Monad.State.Lazy ( StateT(..) + , MonadState(..) + , evalStateT + , execStateT + , mapStateT ) +import Control.Monad.Reader ( ReaderT(..) ) +import Control.Monad.Writer.Lazy ( WriterT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Writer.Class ( MonadWriter + , listen + , tell + , writer + , pass ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) +import Data.Monoid ( Monoid ) + + + +-- | A State transformer monad patameterized by: +-- +-- * x - The list of types constituting the state, +-- * m - The inner monad. +-- +-- 'MultiStateT' corresponds to mtl's 'StateT', but can contain +-- a heterogenous list of types. +-- +-- This heterogenous list is represented using Types.Data.List, i.e: +-- +-- * @'[]@ - The empty list, +-- * @a ': b@ - A list where @/a/@ is an arbitrary type +-- and @/b/@ is the rest list. +-- +-- For example, +-- +-- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *) +-- +-- is a State wrapper containing the types [Int, Bool]. +newtype MultiStateT x m a = MultiStateT { + runMultiStateTRaw :: StateT (HList x) m a +} + +-- | A MultiState transformer carrying an empty state. +type MultiStateTNull = MultiStateT '[] + +-- | A state monad parameterized by the list of types x of the state to carry. +-- +-- Similar to @State s = StateT s Identity@ +type MultiState x = MultiStateT x Identity + +-- some instances + +instance (Functor f) => Functor (MultiStateT x f) where + fmap f = MultiStateT . fmap f . runMultiStateTRaw + +instance (Applicative m, Monad m) => Applicative (MultiStateT x m) where + pure = MultiStateT . pure + (<*>) = ap + +instance Monad m => Monad (MultiStateT x m) where + return = MultiStateT . return + k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) + +instance MonadTrans (MultiStateT x) where + lift = MultiStateT . lift + +instance (Monad m, ContainsType a c) + => MonadMultiState a (MultiStateT c m) where + mSet v = MultiStateT $ get >>= put . setHListElem v + mGet = MultiStateT $ liftM getHListElem get + +-- methods + +-- | A raw extractor of the contained HList (i.e. the complete state). +mGetRaw :: Monad m => MultiStateT a m (HList a) +mGetRaw = MultiStateT get + +mPutRaw :: Monad m => HList s -> MultiStateT s m () +mPutRaw = MultiStateT . put + +-- | Map both the return value and the state of a computation +-- using the given function. +mapMultiStateT :: (m (a, HList w) -> m' (a', HList w)) + -> MultiStateT w m a + -> MultiStateT w m' a' +mapMultiStateT f = MultiStateT . mapStateT f . runMultiStateTRaw + +runMultiStateT :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) +runMultiStateTAS :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) +runMultiStateTSA :: Monad m => HList s -> MultiStateT s m a -> m (HList s, a) +runMultiStateTA :: Monad m => HList s -> MultiStateT s m a -> m a +runMultiStateTS :: Monad m => HList s -> MultiStateT s m a -> m (HList s) +runMultiStateT_ :: Functor m => HList s -> MultiStateT s m a -> m () +-- ghc too dumb for this shortcut, unfortunately +-- runMultiStateT s k = runMultiStateTNil $ withMultiStates s k +-- runMultiStateTAS s k = runMultiStateTNil $ withMultiStatesAS s k +-- runMultiStateTSA s k = runMultiStateTNil $ withMultiStatesSA s k +-- runMultiStateTA s k = runMultiStateTNil $ withMultiStatesA s k +-- runMultiStateTS s k = runMultiStateTNil $ withMultiStatesS s k +-- runMultiStateT_ s k = runMultiStateTNil $ withMultiStates_ s k +runMultiStateT s k = runMultiStateTAS s k +runMultiStateTAS s k = runStateT (runMultiStateTRaw k) s +runMultiStateTSA s k = (\(~(a,b)) -> (b,a)) `liftM` runStateT (runMultiStateTRaw k) s +runMultiStateTA s k = evalStateT (runMultiStateTRaw k) s +runMultiStateTS s k = execStateT (runMultiStateTRaw k) s +runMultiStateT_ s k = void $ runStateT (runMultiStateTRaw k) s + +runMultiStateTNil :: Monad m => MultiStateT '[] m a -> m a +runMultiStateTNil_ :: Functor m => MultiStateT '[] m a -> m () +runMultiStateTNil k = evalStateT (runMultiStateTRaw k) HNil +runMultiStateTNil_ k = void $ runStateT (runMultiStateTRaw k) HNil + +withMultiState :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) +withMultiStateAS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) +withMultiStateSA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (s, a) +withMultiStateA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m a +withMultiStateS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m s +withMultiState_ :: (Functor m, Monad m) => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m () +withMultiState = withMultiStateAS +withMultiStateAS x k = MultiStateT $ do + s <- get + ~(a, s') <- lift $ runStateT (runMultiStateTRaw k) (x :+: s) + case s' of x' :+: sr' -> do put sr'; return (a, x') +withMultiStateSA s k = (\(~(a,b)) -> (b,a)) `liftM` withMultiStateAS s k +withMultiStateA s k = fst `liftM` withMultiStateAS s k +withMultiStateS s k = snd `liftM` withMultiStateAS s k +withMultiState_ s k = void $ withMultiStateAS s k + +withMultiStates :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) +withMultiStatesAS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) +withMultiStatesSA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1, a) +withMultiStatesA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m a +withMultiStatesS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1) +withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m () +withMultiStates = withMultiStatesAS +withMultiStatesAS HNil = liftM (\r -> (r, HNil)) +withMultiStatesAS (x :+: xs) = liftM (\(~(~(a, x'), xs')) -> (a, x' :+: xs')) + . withMultiStatesAS xs + . withMultiStateAS x +withMultiStatesSA HNil = liftM (\r -> (HNil, r)) +withMultiStatesSA (x :+: xs) = liftM (\(~(~(a, x'), xs')) -> (x' :+: xs', a)) + . withMultiStatesAS xs + . withMultiStateAS x +withMultiStatesA HNil = id +withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x +withMultiStatesS HNil = liftM (const HNil) +withMultiStatesS (x :+: xs) = liftM (\(~(x', xs')) -> x' :+: xs') + . withMultiStatesAS xs + . withMultiStateS x +withMultiStates_ HNil = liftM (const ()) +withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x + +inflateState :: (Monad m, ContainsType s ss) + => StateT s m a + -> MultiStateT ss m a +inflateState k = do + s <- mGet + ~(x, s') <- lift $ runStateT k s + mSet s' + return x + +inflateReader :: (Monad m, ContainsType r ss) + => ReaderT r m a + -> MultiStateT ss m a +inflateReader k = mGet >>= lift . runReaderT k + +inflateWriter :: (Monad m, ContainsType w ss, Monoid w) + => WriterT w m a + -> MultiStateT ss m a +inflateWriter k = do + ~(x, w) <- lift $ runWriterT k + mSet w + return x + +-- foreign lifting instances + +instance (MonadState s m) => MonadState s (MultiStateT c m) where + put = lift . put + get = lift $ get + state = lift . state + +instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where + writer = lift . writer + tell = lift . tell + listen = MultiStateT . + mapStateT (liftM (\(~(~(a,w), w')) -> ((a, w'), w)) . listen) . + runMultiStateTRaw + pass = MultiStateT . + mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) . + runMultiStateTRaw diff --git a/src/Control/Monad/Trans/MultiState/Strict.hs b/src/Control/Monad/Trans/MultiState/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiState/Strict.hs @@ -0,0 +1,243 @@ +-- | The multi-valued version of mtl's State / StateT +module Control.Monad.Trans.MultiState.Strict + ( + -- * MultiStateT + MultiStateT(..) + , MultiStateTNull + , MultiState + -- * MonadMultiState class + , MonadMultiState(..) + -- * run-functions + , runMultiStateT + , runMultiStateTAS + , runMultiStateTSA + , runMultiStateTA + , runMultiStateTS + , runMultiStateT_ + , runMultiStateTNil + , runMultiStateTNil_ + -- * with-functions (single state) + , withMultiState + , withMultiStateAS + , withMultiStateSA + , withMultiStateA + , withMultiStateS + , withMultiState_ + -- * with-functions (multiple states) + , withMultiStates + , withMultiStatesAS + , withMultiStatesSA + , withMultiStatesA + , withMultiStatesS + , withMultiStates_ + -- * inflate-functions (run single state in multiple states) + , inflateState + , inflateReader + , inflateWriter + -- * other functions + , mapMultiStateT + , mGetRaw + , mPutRaw +) where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiState.Class + +import Control.Monad.State.Strict ( StateT(..) + , MonadState(..) + , evalStateT + , execStateT + , mapStateT ) +import Control.Monad.Reader ( ReaderT(..) ) +import Control.Monad.Writer.Strict ( WriterT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Writer.Class ( MonadWriter + , listen + , tell + , writer + , pass ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) +import Data.Monoid ( Monoid ) + + + +-- | A State transformer monad patameterized by: +-- +-- * x - The list of types constituting the state, +-- * m - The inner monad. +-- +-- 'MultiStateT' corresponds to mtl's 'StateT', but can contain +-- a heterogenous list of types. +-- +-- This heterogenous list is represented using Types.Data.List, i.e: +-- +-- * @'[]@ - The empty list, +-- * @a ': b@ - A list where @/a/@ is an arbitrary type +-- and @/b/@ is the rest list. +-- +-- For example, +-- +-- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *) +-- +-- is a State wrapper containing the types [Int, Bool]. +newtype MultiStateT x m a = MultiStateT { + runMultiStateTRaw :: StateT (HList x) m a +} + +-- | A MultiState transformer carrying an empty state. +type MultiStateTNull = MultiStateT '[] + +-- | A state monad parameterized by the list of types x of the state to carry. +-- +-- Similar to @State s = StateT s Identity@ +type MultiState x = MultiStateT x Identity + +instance (Functor f) => Functor (MultiStateT x f) where + fmap f = MultiStateT . fmap f . runMultiStateTRaw + +instance (Applicative m, Monad m) => Applicative (MultiStateT x m) where + pure = MultiStateT . pure + (<*>) = ap + +instance Monad m => Monad (MultiStateT x m) where + return = MultiStateT . return + k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) + +instance MonadTrans (MultiStateT x) where + lift = MultiStateT . lift + +instance (Monad m, ContainsType a c) + => MonadMultiState a (MultiStateT c m) where + mSet v = MultiStateT $ get >>= put . setHListElem v + mGet = MultiStateT $ liftM getHListElem get + +-- methods + +-- | A raw extractor of the contained HList (i.e. the complete state). +mGetRaw :: Monad m => MultiStateT a m (HList a) +mGetRaw = MultiStateT get + +mPutRaw :: Monad m => HList s -> MultiStateT s m () +mPutRaw = MultiStateT . put + +-- | Map both the return value and the state of a computation +-- using the given function. +mapMultiStateT :: (m (a, HList w) -> m' (a', HList w)) + -> MultiStateT w m a + -> MultiStateT w m' a' +mapMultiStateT f = MultiStateT . mapStateT f . runMultiStateTRaw + +runMultiStateT :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) +runMultiStateTAS :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) +runMultiStateTSA :: Monad m => HList s -> MultiStateT s m a -> m (HList s, a) +runMultiStateTA :: Monad m => HList s -> MultiStateT s m a -> m a +runMultiStateTS :: Monad m => HList s -> MultiStateT s m a -> m (HList s) +runMultiStateT_ :: Functor m => HList s -> MultiStateT s m a -> m () +-- ghc too dumb for this shortcut, unfortunately +-- runMultiStateT s k = runMultiStateTNil $ withMultiStates s k +-- runMultiStateTAS s k = runMultiStateTNil $ withMultiStatesAS s k +-- runMultiStateTSA s k = runMultiStateTNil $ withMultiStatesSA s k +-- runMultiStateTA s k = runMultiStateTNil $ withMultiStatesA s k +-- runMultiStateTS s k = runMultiStateTNil $ withMultiStatesS s k +-- runMultiStateT_ s k = runMultiStateTNil $ withMultiStates_ s k +runMultiStateT s k = runMultiStateTAS s k +runMultiStateTAS s k = runStateT (runMultiStateTRaw k) s +runMultiStateTSA s k = (\(a,b) -> (b,a)) `liftM` runStateT (runMultiStateTRaw k) s +runMultiStateTA s k = evalStateT (runMultiStateTRaw k) s +runMultiStateTS s k = execStateT (runMultiStateTRaw k) s +runMultiStateT_ s k = void $ runStateT (runMultiStateTRaw k) s + +runMultiStateTNil :: Monad m => MultiStateT '[] m a -> m a +runMultiStateTNil_ :: Functor m => MultiStateT '[] m a -> m () +runMultiStateTNil k = evalStateT (runMultiStateTRaw k) HNil +runMultiStateTNil_ k = void $ runStateT (runMultiStateTRaw k) HNil + +withMultiState :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) +withMultiStateAS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) +withMultiStateSA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (s, a) +withMultiStateA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m a +withMultiStateS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m s +withMultiState_ :: (Functor m, Monad m) => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m () +withMultiState = withMultiStateAS +withMultiStateAS x k = MultiStateT $ do + s <- get + ~(a, s') <- lift $ runStateT (runMultiStateTRaw k) (x :+: s) + case s' of x' :+: sr' -> do put sr'; return (a, x') +withMultiStateSA s k = (\(a,b) -> (b,a)) `liftM` withMultiStateAS s k +withMultiStateA s k = fst `liftM` withMultiStateAS s k +withMultiStateS s k = snd `liftM` withMultiStateAS s k +withMultiState_ s k = void $ withMultiStateAS s k + +withMultiStates :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) +withMultiStatesAS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) +withMultiStatesSA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1, a) +withMultiStatesA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m a +withMultiStatesS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1) +withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m () +withMultiStates = withMultiStatesAS +withMultiStatesAS HNil = liftM (\r -> (r, HNil)) +withMultiStatesAS (x :+: xs) = liftM (\((a, x'), xs') -> (a, x' :+: xs')) + . withMultiStatesAS xs + . withMultiStateAS x +withMultiStatesSA HNil = liftM (\r -> (HNil, r)) +withMultiStatesSA (x :+: xs) = liftM (\((a, x'), xs') -> (x' :+: xs', a)) + . withMultiStatesAS xs + . withMultiStateAS x +withMultiStatesA HNil = id +withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x +withMultiStatesS HNil = liftM (const HNil) +withMultiStatesS (x :+: xs) = liftM (\(x', xs') -> x' :+: xs') + . withMultiStatesAS xs + . withMultiStateS x +withMultiStates_ HNil = liftM (const ()) +withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x + +inflateState :: (Monad m, ContainsType s ss) + => StateT s m a + -> MultiStateT ss m a +inflateState k = do + s <- mGet + (x, s') <- lift $ runStateT k s + mSet s' + return x + +inflateReader :: (Monad m, ContainsType r ss) + => ReaderT r m a + -> MultiStateT ss m a +inflateReader k = mGet >>= lift . runReaderT k + +inflateWriter :: (Monad m, ContainsType w ss, Monoid w) + => WriterT w m a + -> MultiStateT ss m a +inflateWriter k = do + (x, w) <- lift $ runWriterT k + mSet w + return x + +-- foreign lifting instances + +instance (MonadState s m) => MonadState s (MultiStateT c m) where + put = lift . put + get = lift $ get + state = lift . state + +instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where + writer = lift . writer + tell = lift . tell + listen = MultiStateT . + mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . + runMultiStateTRaw + pass = MultiStateT . + mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . + runMultiStateTRaw diff --git a/src/Control/Monad/Trans/MultiWriter.hs b/src/Control/Monad/Trans/MultiWriter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiWriter.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | The multi-valued version of mtl's Writer / WriterT +-- / MonadWriter +module Control.Monad.Trans.MultiWriter + ( -- * MultiWriterT + MultiWriterT(..) + , MultiWriterTNull + , MultiWriter + -- * MonadMultiWriter class + , MonadMultiWriter(..) + -- * run-functions + , runMultiWriterT + , runMultiWriterTAW + , runMultiWriterTWA + , runMultiWriterTW + , runMultiWriterTNil + , runMultiWriterTNil_ + -- * with-functions (single Writer) + , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + -- * with-functions (multiple Writers) + , withMultiWriters + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + -- * other functions + , mapMultiWriterT + , mGetRaw + , mPutRaw + ) +where + + + +-- just re-exports +import Control.Monad.Trans.MultiWriter.Class +import Control.Monad.Trans.MultiWriter.Lazy diff --git a/src/Control/Monad/Trans/MultiWriter/Class.hs b/src/Control/Monad/Trans/MultiWriter/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiWriter/Class.hs @@ -0,0 +1,24 @@ +-- | The multi-valued version of mtl's MonadWriter +module Control.Monad.Trans.MultiWriter.Class + ( + -- * MonadMultiWriter class + MonadMultiWriter(..) + ) +where + + + +import Control.Monad.Trans.Class ( MonadTrans + , lift ) + +import Data.Monoid + + + +-- TODO: some haddock +class (Monad m, Monoid a) => MonadMultiWriter a m where + mTell :: a -> m () + +instance (MonadTrans t, Monad (t m), MonadMultiWriter a m) + => MonadMultiWriter a (t m) where + mTell = lift . mTell diff --git a/src/Control/Monad/Trans/MultiWriter/Lazy.hs b/src/Control/Monad/Trans/MultiWriter/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiWriter/Lazy.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The multi-valued version of mtl's Writer / WriterT +module Control.Monad.Trans.MultiWriter.Lazy + ( + -- * MultiWriterT + MultiWriterT(..) + , MultiWriterTNull + , MultiWriter + -- * run-functions + , runMultiWriterT + , runMultiWriterTAW + , runMultiWriterTWA + , runMultiWriterTW + , runMultiWriterTNil + , runMultiWriterTNil_ + -- * with-functions (single Writer) + , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + -- * with-functions (multiple Writers) + , withMultiWriters + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + -- * inflate-function (run WriterT in MultiWriterT) + , inflateWriter + -- * other functions + , mapMultiWriterT + , mGetRaw + , mPutRaw + ) +where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) + +import Control.Monad.State.Lazy ( StateT(..) + , MonadState(..) + , execStateT + , evalStateT + , mapStateT ) +import Control.Monad.Writer.Lazy ( WriterT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Writer.Class ( MonadWriter + , listen + , tell + , writer + , pass ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) + +import Data.Monoid + + + +-- | A Writer transformer monad patameterized by: +-- +-- * x - The list of types that can be written (Monoid instances). +-- * m - The inner monad. +-- +-- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain +-- a heterogenous list of types. +-- +-- This heterogenous list is represented using Types.Data.List, i.e: +-- +-- * @'[]@ - The empty list, +-- * @a ': b@ - A list where @/a/@ is an arbitrary type +-- and @/b/@ is the rest list. +-- +-- For example, +-- +-- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *) +-- +-- is a Writer transformer containing the types [Int, Bool]. +newtype MultiWriterT x m a = MultiWriterT { + runMultiWriterTRaw :: StateT (HList x) m a +} + +-- | A MultiWriter transformer carrying an empty state. +type MultiWriterTNull = MultiWriterT '[] + +type MultiWriter x a = MultiWriterT x Identity a + +instance (Functor f) => Functor (MultiWriterT x f) where + fmap f = MultiWriterT . fmap f . runMultiWriterTRaw + +instance (Applicative m, Monad m) => Applicative (MultiWriterT x m) where + pure = MultiWriterT . pure + (<*>) = ap + +instance Monad m => Monad (MultiWriterT x m) where + return = MultiWriterT . return + k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw . f) + +instance MonadTrans (MultiWriterT x) where + lift = MultiWriterT . lift + +instance (Monad m, ContainsType a c, Monoid a) + => MonadMultiWriter a (MultiWriterT c m) where + mTell v = MultiWriterT $ do + x <- get + put $ setHListElem (getHListElem x `mappend` v) x + +-- methods + +-- | A raw extractor of the contained HList (i.e. the complete state). +mGetRaw :: Monad m => MultiWriterT a m (HList a) +mGetRaw = MultiWriterT get + +mPutRaw :: Monad m => HList s -> MultiWriterT s m () +mPutRaw = MultiWriterT . put + +-- | Map both the return value and the state of a computation +-- using the given function. +mapMultiWriterT :: (m (a, HList w) -> m' (a', HList w)) + -> MultiWriterT w m a + -> MultiWriterT w m' a' +mapMultiWriterT f = MultiWriterT . mapStateT f . runMultiWriterTRaw + +runMultiWriterT :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) +runMultiWriterTAW :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) +runMultiWriterTWA :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w, a) +runMultiWriterTW :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w) +runMultiWriterT = runMultiWriterTAW +runMultiWriterTAW k = runStateT (runMultiWriterTRaw k) mempty +runMultiWriterTWA k = (\(~(a,b)) -> (b,a)) `liftM` runStateT (runMultiWriterTRaw k) mempty +runMultiWriterTW k = execStateT (runMultiWriterTRaw k) mempty + +runMultiWriterTNil :: Monad m => MultiWriterT '[] m a -> m a +runMultiWriterTNil_ :: Functor m => MultiWriterT '[] m a -> m () +runMultiWriterTNil k = evalStateT (runMultiWriterTRaw k) HNil +runMultiWriterTNil_ k = void $ runStateT (runMultiWriterTRaw k) HNil + +withMultiWriter :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) +withMultiWriterAW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) +withMultiWriterWA :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (w, a) +withMultiWriterW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m w +withMultiWriter = withMultiWriterAW +withMultiWriterAW k = MultiWriterT $ do + w <- get + ~(a, w') <- lift $ runStateT (runMultiWriterTRaw k) (mempty :+: w) + case w' of x' :+: wr' -> do put wr'; return (a, x') +withMultiWriterWA k = (\(~(a,b)) -> (b,a)) `liftM` withMultiWriterAW k +withMultiWriterW k = snd `liftM` withMultiWriterAW k + +withMultiWriters :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (a, HList w1) +withMultiWritersAW :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (a, HList w1) +withMultiWritersWA :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (HList w1, a) +-- withMultiWritersA would have too much ambiguity for what the ws are +-- (one could use a Proxy, but that does not seem to be worth the effort) +-- same reasoning for withMultiWriters_ +withMultiWritersW :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (HList w1) +withMultiWriters = withMultiWritersAW +withMultiWritersAW k = MultiWriterT $ do + w <- get + ~(a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) + let (o, w') = hSplit ws' + put w' + return $ (a, o) +withMultiWritersWA k = MultiWriterT $ do + w <- get + ~(a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) + let (o, w') = hSplit ws' + put w' + return $ (o, a) +withMultiWritersW k = MultiWriterT $ do + w <- get + ws' <- lift $ execStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) + let (o, w') = hSplit ws' + put w' + return $ o + +inflateWriter :: (Monad m, Monoid w, ContainsType w ws) + => WriterT w m a + -> MultiWriterT ws m a +inflateWriter k = do + (x, w) <- lift $ runWriterT k + mTell w + return x + +-- foreign lifting instances + +instance (MonadState s m) => MonadState s (MultiWriterT c m) where + put = lift . put + get = lift $ get + state = lift . state + +instance (MonadWriter w m) => MonadWriter w (MultiWriterT c m) where + writer = lift . writer + tell = lift . tell + listen = MultiWriterT . + mapStateT (liftM (\(~(~(a,w), w')) -> ((a, w'), w)) . listen) . + runMultiWriterTRaw + pass = MultiWriterT . + mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) . + runMultiWriterTRaw diff --git a/src/Control/Monad/Trans/MultiWriter/Strict.hs b/src/Control/Monad/Trans/MultiWriter/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/MultiWriter/Strict.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The multi-valued version of mtl's Writer / WriterT +module Control.Monad.Trans.MultiWriter.Strict + ( + -- * MultiWriterT + MultiWriterT(..) + , MultiWriterTNull + , MultiWriter + -- * run-functions + , runMultiWriterT + , runMultiWriterTAW + , runMultiWriterTWA + , runMultiWriterTW + , runMultiWriterTNil + , runMultiWriterTNil_ + -- * with-functions (single Writer) + , withMultiWriter + , withMultiWriterAW + , withMultiWriterWA + , withMultiWriterW + -- * with-functions (multiple Writers) + , withMultiWriters + , withMultiWritersAW + , withMultiWritersWA + , withMultiWritersW + -- * inflate-function (run WriterT in MultiWriterT) + , inflateWriter + -- * other functions + , mapMultiWriterT + , mGetRaw + , mPutRaw + ) +where + + + +import Data.HList.HList +import Data.HList.ContainsType + +import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) + +import Control.Monad.State.Strict ( StateT(..) + , MonadState(..) + , execStateT + , evalStateT + , mapStateT ) +import Control.Monad.Writer.Strict ( WriterT(..) ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Writer.Class ( MonadWriter + , listen + , tell + , writer + , pass ) + +import Data.Functor.Identity ( Identity ) + +import Control.Applicative ( Applicative(..) ) +import Control.Monad ( liftM + , ap + , void ) + +import Data.Monoid + + + +-- | A Writer transformer monad patameterized by: +-- +-- * x - The list of types that can be written (Monoid instances). +-- * m - The inner monad. +-- +-- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain +-- a heterogenous list of types. +-- +-- This heterogenous list is represented using Types.Data.List, i.e: +-- +-- * @'[]@ - The empty list, +-- * @a ': b@ - A list where @/a/@ is an arbitrary type +-- and @/b/@ is the rest list. +-- +-- For example, +-- +-- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *) +-- +-- is a Writer transformer containing the types [Int, Bool]. +newtype MultiWriterT x m a = MultiWriterT { + runMultiWriterTRaw :: StateT (HList x) m a +} + +-- | A MultiWriter transformer carrying an empty state. +type MultiWriterTNull = MultiWriterT '[] + +type MultiWriter x a = MultiWriterT x Identity a + +instance (Functor f) => Functor (MultiWriterT x f) where + fmap f = MultiWriterT . fmap f . runMultiWriterTRaw + +instance (Applicative m, Monad m) => Applicative (MultiWriterT x m) where + pure = MultiWriterT . pure + (<*>) = ap + +instance Monad m => Monad (MultiWriterT x m) where + return = MultiWriterT . return + k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw.f) + +instance MonadTrans (MultiWriterT x) where + lift = MultiWriterT . lift + +instance (Monad m, ContainsType a c, Monoid a) + => MonadMultiWriter a (MultiWriterT c m) where + mTell v = MultiWriterT $ do + x <- get + put $ setHListElem (getHListElem x `mappend` v) x + +-- methods + +-- | A raw extractor of the contained HList (i.e. the complete state). +mGetRaw :: Monad m => MultiWriterT a m (HList a) +mGetRaw = MultiWriterT get + +mPutRaw :: Monad m => HList s -> MultiWriterT s m () +mPutRaw = MultiWriterT . put + +-- | Map both the return value and the state of a computation +-- using the given function. +mapMultiWriterT :: (m (a, HList w) -> m' (a', HList w)) + -> MultiWriterT w m a + -> MultiWriterT w m' a' +mapMultiWriterT f = MultiWriterT . mapStateT f . runMultiWriterTRaw + +runMultiWriterT :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) +runMultiWriterTAW :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) +runMultiWriterTWA :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w, a) +runMultiWriterTW :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w) +runMultiWriterT = runMultiWriterTAW +runMultiWriterTAW k = runStateT (runMultiWriterTRaw k) mempty +runMultiWriterTWA k = (\(a,b) -> (b,a)) `liftM` runStateT (runMultiWriterTRaw k) mempty +runMultiWriterTW k = execStateT (runMultiWriterTRaw k) mempty + +runMultiWriterTNil :: Monad m => MultiWriterT '[] m a -> m a +runMultiWriterTNil_ :: Functor m => MultiWriterT '[] m a -> m () +runMultiWriterTNil k = evalStateT (runMultiWriterTRaw k) HNil +runMultiWriterTNil_ k = void $ runStateT (runMultiWriterTRaw k) HNil + +withMultiWriter :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) +withMultiWriterAW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) +withMultiWriterWA :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (w, a) +withMultiWriterW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m w +withMultiWriter = withMultiWriterAW +withMultiWriterAW k = MultiWriterT $ do + w <- get + (a, w') <- lift $ runStateT (runMultiWriterTRaw k) (mempty :+: w) + case w' of x' :+: wr' -> do put wr'; return (a, x') +withMultiWriterWA k = (\(a,b) -> (b,a)) `liftM` withMultiWriterAW k +withMultiWriterW k = snd `liftM` withMultiWriterAW k + +withMultiWriters :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (a, HList w1) +withMultiWritersAW :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (a, HList w1) +withMultiWritersWA :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (HList w1, a) +-- withMultiWritersA would have too much ambiguity for what the ws are +-- (one could use a Proxy, but that does not seem to be worth the effort) +-- same reasoning for withMultiWriters_ +withMultiWritersW :: forall w1 w2 m a + . (Monoid (HList w1), Monad m, HInit w1) + => MultiWriterT (Append w1 w2) m a + -> MultiWriterT w2 m (HList w1) +withMultiWriters = withMultiWritersAW +withMultiWritersAW k = MultiWriterT $ do + w <- get + (a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) + let (o, w') = hSplit ws' + put w' + return $ (a, o) +withMultiWritersWA k = MultiWriterT $ do + w <- get + (a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) + let (o, w') = hSplit ws' + put w' + return $ (o, a) +withMultiWritersW k = MultiWriterT $ do + w <- get + ws' <- lift $ execStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) + let (o, w') = hSplit ws' + put w' + return $ o + +inflateWriter :: (Monad m, Monoid w, ContainsType w ws) + => WriterT w m a + -> MultiWriterT ws m a +inflateWriter k = do + (x, w) <- lift $ runWriterT k + mTell w + return x + +-- foreign lifting instances + +instance (MonadState s m) => MonadState s (MultiWriterT c m) where + put = lift . put + get = lift $ get + state = lift . state + +instance (MonadWriter w m) => MonadWriter w (MultiWriterT c m) where + writer = lift . writer + tell = lift . tell + listen = MultiWriterT . + mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . + runMultiWriterTRaw + pass = MultiWriterT . + mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . + runMultiWriterTRaw diff --git a/src/Data/HList/ContainsType.hs b/src/Data/HList/ContainsType.hs new file mode 100644 --- /dev/null +++ b/src/Data/HList/ContainsType.hs @@ -0,0 +1,23 @@ +-- | Class to provide type-driven access to elements of a HList +module Data.HList.ContainsType + ( ContainsType(..) + ) +where + + + +import Data.HList.HList + + + +class ContainsType a c where + setHListElem :: a -> HList c -> HList c + getHListElem :: HList c -> a + +instance ContainsType a (a ': xs) where + setHListElem a xs = a :+: case xs of (_ :+: xr) -> xr + getHListElem (x :+: _) = x + +instance (ContainsType a xs) => ContainsType a (x ': xs) where + setHListElem a (x :+: xr) = x :+: setHListElem a xr + getHListElem (_ :+: xr) = getHListElem xr diff --git a/src/Data/HList/HList.hs b/src/Data/HList/HList.hs --- a/src/Data/HList/HList.hs +++ b/src/Data/HList/HList.hs @@ -2,6 +2,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} -- | A GADT HList implementation -- @@ -10,6 +13,8 @@ module Data.HList.HList ( HList(..) , Append + , hAppend + , HInit(..) ) where @@ -18,8 +23,10 @@ import Data.Monoid +import Data.Proxy + data HList :: [*] -> * where HNil :: HList '[] (:+:) :: x -> HList xs -> HList (x ': xs) @@ -29,10 +36,10 @@ infixr 5 :+: instance Show (HList '[]) where - show _ = "()" + show _ = "HNil" instance (Show a, Show (HList b)) => Show (HList (a ': b)) where - show (x :+: y) = "(" ++ show x ++ "," ++ show y ++ ")" + show (x :+: y) = "(" ++ show x ++ ":+:" ++ show y ++ ")" instance Monoid (HList '[]) where mempty = HNil @@ -58,3 +65,21 @@ type family Append (l1::[*]) (l2::[*]) :: [*] type instance Append '[] l2 = l2 type instance Append (car1 ': cdr2) l2 = car1 ': Append cdr2 l2 + +hAppend :: HList ts1 -> HList ts2 -> HList (Append ts1 ts2) +hAppend HNil l = l +hAppend (x:+:xs) l = x :+: hAppend xs l + +class HInit (l1 :: [*]) where + hInit :: forall l2 . Proxy l2 -> HList (Append l1 l2) -> HList l1 + hSplit :: forall l2 . HList (Append l1 l2) -> (HList l1, HList l2) + +instance HInit '[] where + hInit _ _ = HNil + hSplit l = (HNil, l) +instance HInit l1 => HInit (x ': l1) where + hInit p (x :+: xs) = x :+: hInit p xs + hInit _ _ = error "cannot happen" -- see ghc trac #3927 + hSplit (x :+: xs) = let (l1, l2) = hSplit xs + in (x :+: l1, l2) + hSplit _ = error "cannot happen" diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -10,25 +10,27 @@ import Data.Functor.Identity import Data.HList.HList import Data.Monoid -import qualified Control.Monad.MultiState as MS -import qualified Control.Monad.MultiReader as MR -import qualified Control.Monad.MultiWriter as MW +import qualified Control.Monad.Trans.MultiState as MS +import qualified Control.Monad.Trans.MultiReader as MR +import qualified Control.Monad.Trans.MultiWriter as MW import Control.Applicative ( Applicative, (<$>), (<*>) ) +import Test.Hspec + type Tests = [(Bool, String)] runEvalMS :: MS.MultiStateT '[] Identity a -> a -runEvalMS = runIdentity . MS.evalMultiStateT +runEvalMS = runIdentity . MS.runMultiStateTNil runEvalMR :: MR.MultiReaderT '[] Identity a -> a -runEvalMR = runIdentity . MR.evalMultiReaderT +runEvalMR = runIdentity . MR.runMultiReaderTNil runExecMW :: Monoid (HList x) => MW.MultiWriterT x Identity a -> HList x -runExecMW = runIdentity . MW.execMultiWriterT +runExecMW = runIdentity . MW.runMultiWriterTW runnerMS :: a -> MS.MultiStateT '[a] Identity a -> a -runnerMS x m = runEvalMS $ MS.withMultiState x m +runnerMS x m = runEvalMS $ MS.withMultiStateA x m runnerMR :: a -> MR.MultiReaderT '[a] Identity a -> a runnerMR x m = runEvalMR $ MR.withMultiReader x m runnerMW :: Monoid a => MW.MultiWriterT '[a] Identity b -> a @@ -38,11 +40,11 @@ runnerMS_ :: a -> MS.MultiStateT '[a] Identity b -> a runnerMS_ x m = runIdentity - $ MS.evalMultiStateT - $ MS.withMultiState x (m >> MS.mGet) + $ MS.runMultiStateTNil + $ MS.withMultiStateA x (m >> MS.mGet) runnerMR_ :: a -> MR.MultiReaderT '[a] Identity b -> a runnerMR_ x m = runIdentity - $ MR.evalMultiReaderT + $ MR.runMultiReaderTNil $ MR.withMultiReader x (m >> MR.mAsk) intRunnerMS :: Int -> MS.MultiStateT '[Int] Identity Int -> Int @@ -67,102 +69,108 @@ => m (a,b) msGetTuple = (,) <$> MS.mGet <*> MS.mGet -testsMultiState :: Tests -testsMultiState = - [ - (1 == runIdentity (Identity (1::Int)) - , "identity"), - (2 == intRunnerMS_ 2 (return ()) - , "multistate getConfig"), - (3 == intRunnerMS_ 100 (MS.mSet (3::Int)) - , "multistate setConfig"), - (4 == intRunnerMS_ 4 (MS.mGet >>= \x -> MS.mSet (x::Int)) - , "multistate setConfig"), - (5 == intRunnerMS (4::Int) (MS.withMultiState (5::Int) MS.mGet) - , "multistate nesting"), - (6 == intRunnerMS (4::Int) ( MS.mSet (100::Int) - >> MS.withMultiState (6::Int) MS.mGet) - , "multistate nesting"), - (7 == intRunnerMS (4::Int) ( MS.withMultiState (100::Int) - $ MS.mSet (7::Int) - >> MS.mGet) - , "multistate nesting"), - ((True, 'a') == ( runEvalMS - $ MS.withMultiState True - $ MS.withMultiState 'a' - $ msGetTuple ) - , "multistate multiple types"), - ((True, 'b') == ( runEvalMS - $ MS.withMultiState True - $ MS.withMultiState 'a' - $ MS.withMultiState 'b' - $ msGetTuple ) - , "multistate multiple types"), - ((False, 'a') == ( runEvalMS - $ MS.withMultiState True - $ MS.withMultiState 'a' - $ MS.withMultiState False - $ msGetTuple ) - , "multistate multiple types"), - (test13MS - , "askRaw") - ] +testsMultiState :: Spec +testsMultiState = do + it "identity" $ 1 `shouldBe` runIdentity (Identity (1::Int)) + it "getConfig" + $ intRunnerMS_ 2 (return ()) + `shouldBe` 2 + it "setConfig" + $ intRunnerMS_ 100 (MS.mSet (3::Int)) + `shouldBe` 3 + it "setConfig" + $ intRunnerMS_ 4 (MS.mGet >>= \x -> MS.mSet (x::Int)) + `shouldBe` 4 + it "nesting 1" + $ intRunnerMS (4::Int) (MS.withMultiStateA (5::Int) MS.mGet) + `shouldBe` 5 + it "nesting 2" + $ intRunnerMS (4::Int) ( MS.mSet (100::Int) + >> MS.withMultiStateA (6::Int) MS.mGet) + `shouldBe` 6 + it "nesting 3" + $ intRunnerMS (4::Int) (MS.withMultiStateA (100::Int) + $ MS.mSet (7::Int) >> MS.mGet) + `shouldBe` 7 + it "multiple types 1" + $ ( runEvalMS + $ MS.withMultiStateA True + $ MS.withMultiStateA 'a' + $ msGetTuple ) + `shouldBe` (True, 'a') + it "multiple types 2" + $ ( runEvalMS + $ MS.withMultiStateA True + $ MS.withMultiStateA 'a' + $ MS.withMultiStateA 'b' + $ msGetTuple ) + `shouldBe` (True, 'b') + it "askRaw" test13MS -testsMultiReader :: Tests -testsMultiReader = - [ - (1 == runIdentity (Identity (1::Int)) - , "identity"), - (2 == intRunnerMR_ 2 (return ()) - , "multistate getConfig"), - (5 == intRunnerMR (4::Int) (MR.withMultiReader (5::Int) MR.mAsk) - , "multistate nesting"), - ((True, 'a') == ( runEvalMR - $ MR.withMultiReader True - $ MR.withMultiReader 'a' - $ mrAskTuple ) - , "multistate multiple types"), - ((True, 'b') == ( runEvalMR - $ MR.withMultiReader True - $ MR.withMultiReader 'a' - $ MR.withMultiReader 'b' - $ mrAskTuple ) - , "multistate multiple types"), - ((False, 'a') == ( runEvalMR - $ MR.withMultiReader True - $ MR.withMultiReader 'a' - $ MR.withMultiReader False - $ mrAskTuple ) - , "multistate multiple types"), - (test13MR - , "getRaw") - ] +testsMultiReader :: Spec +testsMultiReader = do + it "identity" + $ runIdentity (Identity (1::Int)) + `shouldBe` 1 + it "getConfig" + $ intRunnerMR_ 2 (return ()) + `shouldBe` 2 + it "nesting" + $ intRunnerMR (4::Int) (MR.withMultiReader (5::Int) MR.mAsk) + `shouldBe` 5 + it "multiple types 1" + $ ( runEvalMR + $ MR.withMultiReader True + $ MR.withMultiReader 'a' + $ mrAskTuple ) + `shouldBe` (True, 'a') + it "multiple types 2" + $ ( runEvalMR + $ MR.withMultiReader True + $ MR.withMultiReader 'a' + $ MR.withMultiReader 'b' + $ mrAskTuple ) + `shouldBe` (True, 'b') + it "multiple types 3" + $ ( runEvalMR + $ MR.withMultiReader True + $ MR.withMultiReader 'a' + $ MR.withMultiReader False + $ mrAskTuple ) + `shouldBe` (False, 'a') + it "getRaw" test13MR -testsMultiWriter :: Tests -testsMultiWriter = - [ ("" == stringRunnerMW (return ()) - , "multiwriter 1-0") - , ("a" == stringRunnerMW (MW.mTell "a") -- this type annotation is kinda - -- annoying.. - , "multiwriter 1-1") - , ("ab" == stringRunnerMW (MW.mTell "a" >> MW.mTell "b") - , "multiwriter 1-2") - , (("ab" :+: [True] :+: HNil) == runExecMW (MW.mTell "a" >> MW.mTell [True] >> MW.mTell "b") - , "multiwriter 2") - ] +testsMultiWriter :: Spec +testsMultiWriter = do + it "1-0" + $ stringRunnerMW (return ()) + `shouldBe` "" + it "1-1" + $ stringRunnerMW (MW.mTell "a") + `shouldBe` "a" + it "1-2" + $ stringRunnerMW (MW.mTell "a" >> MW.mTell "b") + `shouldBe` "ab" + it "2" + $ runExecMW (MW.mTell "a" >> MW.mTell [True] >> MW.mTell "b") + `shouldBe` ("ab" :+: [True] :+: HNil) -tests :: Tests -tests = testsMultiState ++ testsMultiReader ++ testsMultiWriter +tests :: Spec +tests = do + describe "MultiState" $ testsMultiState + describe "MultiReader" $ testsMultiReader + describe "MultiWriter" $ testsMultiWriter + lazyStateTest test13MR :: Bool test13MR = runIdentity - $ MR.evalMultiReaderT + $ MR.runMultiReaderTNil $ MR.withMultiReader True $ MR.withMultiReader 'a' $ do - c <- MR.mAskRaw + c <- MR.mGetRaw return $ runIdentity - $ MR.evalMultiReaderT + $ MR.runMultiReaderTNil $ MR.withMultiReaders c $ do b <- MR.mAsk @@ -170,31 +178,46 @@ test13MS :: Bool test13MS = runIdentity - $ MS.evalMultiStateT - $ MS.withMultiState True - $ MS.withMultiState 'a' + $ MS.runMultiStateTNil + $ MS.withMultiStateA True + $ MS.withMultiStateA 'a' $ do c <- MS.mGetRaw return $ runIdentity - $ MS.evalMultiStateT - $ MS.withMultiStates c + $ MS.runMultiStateTNil + $ MS.withMultiStatesA c $ do b <- MS.mGet return (b::Bool) +lazyStateTest :: Spec +lazyStateTest = it "lazyStateTest" $ (33, True) `shouldBe` l + where + l :: (Int, Bool) + l = case runIdentity $ MS.runMultiStateTS ([] :+: [] :+: HNil) action of + (x :+: y :+: _) -> (head x, head y) + action :: MS.MultiStateT '[[Int], [Bool]] Identity () + action = do + action + x <- MS.mGet + MS.mSet $ (33::Int):x + y <- MS.mGet + MS.mSet $ True:y + + main :: IO () -main = do - mapM_ (putStrLn . ("error: "++) . snd) $ filter (\(b, _) -> not b) tests - putStrLn $ "ran " - ++ show (length tests) - ++ " tests (no further output = good)" - return () +main = hspec $ tests + -- mapM_ (putStrLn . ("error: "++) . snd) $ filter (\(b, _) -> not b) tests + -- putStrLn $ "ran " + -- ++ show (length tests) + -- ++ " tests (no further output = good)" + -- return () {- main = do evalStateT - (evalMultiReaderT $ withConfig 'a' $ do + (runMultiReaderT $ withConfig 'a' $ do x <- withConfig 'b' getConfig lift $ lift $ print (x::Char) y <- get @@ -202,7 +225,7 @@ return () ) (1::Int) - evalMultiReaderT $ withConfig 'a' $ evalStateT + runMultiReaderT $ withConfig 'a' $ evalStateT ( do x <- getConfig lift $ lift $ print (x::Char)