multistate-0.8.0.4/0000755000000000000000000000000007346545000012245 5ustar0000000000000000multistate-0.8.0.4/LICENSE0000644000000000000000000000274507346545000013262 0ustar0000000000000000Copyright 2013-2014 Jan Bracker Copyright 2013-2017 Lennart Spitzner All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of this library's contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. multistate-0.8.0.4/README.md0000644000000000000000000001424107346545000013526 0ustar0000000000000000# multistate [![Build Status](https://secure.travis-ci.org/lspitzner/multistate.svg)](http://travis-ci.org/lspitzner/multistate) [![Hackage](https://img.shields.io/hackage/v/multistate.svg)](https://hackage.haskell.org/package/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 = runMultiStateTNil_ -- start with an empty state, -- i.e. :: MultiStateT '[] IO $ withMultiStateA 'H' -- "adding" a char to the state $ withMultiStateA "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 | <-------- | | (withoutState) | | | | | | runStateT runStateTNil | \--------------------> m .. <---------------------------/ ~~~~ Specific functions are (constraints omitted): ~~~~ runMultiStateT = runMultiStateTAS 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 = withMultiStateAS 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 = withMultiStatesAS 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 () withoutMultiState :: MultiStateT ss m a -> MultiStateT (s ': ss) m a ~~~~ ## 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 multistate-0.8.0.4/Setup.hs0000644000000000000000000000005607346545000013702 0ustar0000000000000000import Distribution.Simple main = defaultMain multistate-0.8.0.4/changelog.md0000644000000000000000000000607207346545000014523 0ustar0000000000000000# Changelog for [`multistate` package](https://hackage.haskell.org/package/multistate) ## 0.8.0.4 *January 2022* * Adapt for ghc-9.0 and ghc-9.2 * Clean up code a bit, fix compiler warnings (thanks sergv) ## 0.8.0.3 *May 2020* * Adapt for ghc-8.10 * Add nix-expressions for testing against different ghc versions * Drop support for ghc < 8.4 ## 0.8.0.2 *June 2019* * Adapt for ghc-8.8 (optimistically; QuickCheck does not build so tests are untested) ## 0.8.0.1 *October 2018* * Adapt for ghc-8.6 (really, this time) * Make package -Wcompat-ible ## 0.8.0.0 *April 2018* * Adapt for ghc-8.4 * Drop support for ghc<8.0 * Add class `MonadMultiGet` that roughly translates to "any read access" (instances for Reader and State) * Add data-type `MultiGST` that has a single taggified HList instead of the three r, w, s lists with `MultiRWS` ## 0.7.1.2 *August 2017* * Adapt for ghc-8.2 * Minor strictness fix for MultiRWS ## 0.7.1.1 *May 2016* * Adapt for ghc-8 ## 0.7.1.0 *March 2016* * Add new method `withoutMultiFoo`, inverse of `withMultiFoo` ## 0.7.0.0 *February 2016* * Add instances: + MonadIO + Alternative + MonadPlus + MonadBase + MonadTransControl + MonadBaseControl ## 0.6.2.0 *June 2015* * Add MonadFix instances ## 0.6.1.0 *June 2015* * Export classes from transformer modules ## 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 *January 2015* * Add `MultiWriter` * Fixity for `(:+:)` * support ghc-7.10 ## 0.2.0.0 *January 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 multistate-0.8.0.4/example/0000755000000000000000000000000007346545000013700 5ustar0000000000000000multistate-0.8.0.4/example/Example.hs0000644000000000000000000000671607346545000015641 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module Main where 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, 2) the polymorphic mGet, 3) how to initially put values into the MultiState using withMultiState, 4) the type inference at work - note that there was no need to annotate combinedPrint -} simpleExample :: IO () simpleExample = runMultiStateTNil_ $ withMultiState 'H' -- add a Char to the state $ withMultiState "ello, World!" -- add a String to the state $ do -- the monad here is MultiStateT '[String, Char] IO let combinedPrint = do c <- mGet cs <- mGet -- i <- mGet -- No instance for (Control.Monad.MultiState.ContainsType Int '[]) -- lift $ print $ (i :: Int) lift $ putStrLn (c:cs) combinedPrint mSet 'J' -- we set the Char in the state to 'J' combinedPrint -- output: -- "Hello, World! -- Jello, World! -- " -- and a more complex example: newtype Account = Account Float newtype Interest = Interest Float setAccount :: MonadMultiState Account m => Float -> m () setAccount x = mSet (Account x) getAccount :: MonadMultiState Account m => m Float getAccount = do (Account x) <- mGet return x modAccount :: MonadMultiState Account m => (Float -> Float) -> m () modAccount f = do (Account x) <- mGet mSet (Account (f x)) -- wait for a specific time, changing the account according to interest wait :: ( MonadMultiState Account m , MonadMultiState Interest m ) => Float -> m () wait t = do (Interest i) <- mGet (Account x) <- mGet mSet (Account (x*(1+i)**t)) logAccount :: ( MonadWriter [String] m , MonadMultiState Account m) => m () logAccount = do (Account x) <- mGet tell $ ["account balance = " ++ show x] accountCalculation :: Writer [String] () accountCalculation = runMultiStateTNil_ $ do tell ["account calculation start"] -- we cannot use any of the account methods here, because state is empty -- logAccount -- --> -- No instance for (Control.Monad.MultiState.ContainsType Account '[]) withMultiState (Account 0.0) $ do -- state contains an Account. logAccount modAccount (+10.0) logAccount -- trying to use "wait" here would give type error, like above. withMultiState (Interest 0.03) $ do -- state now also contains Interest. wait 10.0 -- we can use wait, because state contains all -- necessary stuff. logAccount modAccount (\x -> x - 10.0) wait 10.0 logAccount mSet (Interest 0.00) wait 10.0 -- we can return back to the environment without interest -- but the changes to the account are still present logAccount -- and we can return to an empty state tell ["account calculation end"] main = do simpleExample mapM_ putStrLn $ execWriter accountCalculation -- whatIsNotPossible :: MultiStateT '[String] IO () -- whatIsNotPossible = mGet >>= (lift . print) -- type ambiguous -- another thing that is not directly possible is the restriction to -- specific values, i.e. a function -- restrict :: MultiStateT xvalues m a -> MultiStateT yvalues m a -- where yvalues is a "superset" of xvalues. --TODO: example with mGetRaw and withMultiStates multistate-0.8.0.4/multistate.cabal0000644000000000000000000000703107346545000015425 0ustar0000000000000000Name: multistate Version: 0.8.0.4 Cabal-Version: >= 1.10 Build-Type: Simple license: BSD3 license-file: LICENSE Copyright: Copyright (C) 2013 Jan Bracker, 2013-2020 Lennart Spitzner Maintainer: Lennart Spitzner Author: Jan Bracker, Lennart Spitzner Homepage: https://github.com/lspitzner/multistate Bug-reports: https://github.com/lspitzner/multistate/issues Stability: Experimental category: Control 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, 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\/MultiRWST can contain a heterogeneous list of values. . See the for a longer description. extra-source-files: README.md changelog.md source-repository head { type: git location: git@github.com:lspitzner/multistate.git } flag build-example description: Build the MultiState-example example program default: False manual: True library { default-language: Haskell2010 exposed-modules: Data.HList.HList Data.HList.ContainsType Control.Monad.Trans.MultiGet.Class 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 Control.Monad.Trans.MultiGST Control.Monad.Trans.MultiGST.Lazy Control.Monad.Trans.MultiGST.Strict other-modules: Control.Monad.Trans.MultiGST.Common build-depends: base >= 4.11 && <4.17, mtl >= 2.1 && <2.3, transformers >= 0.3 && <0.6, tagged >= 0.7 && <0.9, transformers-base <0.5, monad-control >= 1.0 && <1.1 default-extensions: GADTs TypeFamilies MultiParamTypeClasses FunctionalDependencies FlexibleContexts FlexibleInstances UndecidableInstances TypeOperators DataKinds LambdaCase ghc-options: { -Wall -Wcompat -fno-warn-unused-imports -fno-warn-redundant-constraints } hs-source-dirs: src } 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 <999, transformers <0.6, hspec >=2 && <2.9 ghc-options: -Wall main-is: Test.hs hs-source-dirs: test } executable multistate-example { default-language: Haskell2010 if flag(build-example) { buildable: True build-depends: -- no version constraints necessary, because they are already -- given by library multistate, base <999, mtl <2.3, transformers <0.6 } else { buildable: False } main-is: Example.hs hs-source-dirs: example } multistate-0.8.0.4/src/Control/Monad/Trans/0000755000000000000000000000000007346545000016601 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiGST.hs0000644000000000000000000000156107346545000020610 0ustar0000000000000000-- | The multi-valued version of mtl's RWS / RWST module Control.Monad.Trans.MultiGST ( -- * MultiRWST MultiGSTT(..) , MultiGSTTNull , MultiGST -- * MonadMulti classes , ContainsReader , ContainsState , ContainsWriter , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiGet(..) , CanReadWrite(..) -- * run-functions (extracting from RWST) , runMultiGSTTNil , runMultiGSTTNil_ -- * with-functions (extending an RWST) , withReader , withReader_ , withReaders , withWriter , withWriterAW , withWriterWA , withWriterW , withState , withStateAS , withStateSA , withStateA , withStateS , withState_ -- * without-functions (reducing an RWST; inverse of with) , without -- * other functions , mapMultiGSTT , mGetRawR , mSetRaw , mGetRaw ) where -- just re-export import Control.Monad.Trans.MultiGST.Lazy multistate-0.8.0.4/src/Control/Monad/Trans/MultiGST/0000755000000000000000000000000007346545000020251 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiGST/Common.hs0000644000000000000000000001505007346545000022036 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -- | Common definitions for MultiGST.Strict and MultiGST.Lazy module Control.Monad.Trans.MultiGST.Common ( HListM(..) , CanReadWrite(..) , CanReadWriteFlag(..) , HListMContainsImplication , HListMContains(..) , ContainsReader , ContainsState , ContainsWriter , CanWriteConstraint , AppendM , HListMReaders , AppendMReaders , HListMGettableClass(..) ) where import Data.Kind (Type) import Data.Semigroup import qualified Data.HList.HList as HList import Control.Monad.Trans.MultiReader.Class import Control.Monad.Trans.MultiWriter.Class import Control.Monad.Trans.MultiState.Class import GHC.Exts (Constraint) data CanReadWrite a = Gettable a | Settable a | Tellable a data CanReadWriteFlag = GettableFlag | SettableFlag | TellableFlag type family HListMContainsImplication (can :: CanReadWriteFlag) t cts :: Constraint where HListMContainsImplication 'GettableFlag t cts = () HListMContainsImplication 'TellableFlag t cts = () HListMContainsImplication 'SettableFlag t cts = HListMContains 'GettableFlag t cts class HListMContainsImplication can t cts => HListMContains (can :: CanReadWriteFlag) t cts where readHListMElem :: HListM cts -> t writeHListMElem :: CanWriteConstraint can => t -> HListM cts -> HListM cts type ContainsReader = HListMContains 'GettableFlag type ContainsState = HListMContains 'SettableFlag type ContainsWriter = HListMContains 'TellableFlag instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif HListMContains 'GettableFlag x ('Gettable x ': tr) where readHListMElem (x :+-: _) = x writeHListMElem = error "writeHListMElem CanRead" -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled.. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif HListMContains 'GettableFlag x ('Settable x ': tr) where readHListMElem (x :++: _) = x writeHListMElem = error "writeHListMElem CanRead" -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled.. instance HListMContains 'GettableFlag x ts => HListMContains 'GettableFlag x (t ': ts) where readHListMElem (_ :+-: xr) = readHListMElem @'GettableFlag xr readHListMElem (_ :-+: xr) = readHListMElem @'GettableFlag xr readHListMElem (_ :++: xr) = readHListMElem @'GettableFlag xr writeHListMElem = error "writeHListMElem CanRead" instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif HListMContains 'TellableFlag x ('Tellable x ': tr) where readHListMElem (x :-+: _) = x writeHListMElem x ts = case ts of (_ :-+: tr) -> x :-+: tr instance HListMContains 'TellableFlag x ts => HListMContains 'TellableFlag x (t ': ts) where readHListMElem (_ :+-: xr) = readHListMElem @'TellableFlag xr readHListMElem (_ :-+: xr) = readHListMElem @'TellableFlag xr readHListMElem (_ :++: xr) = readHListMElem @'TellableFlag xr writeHListMElem x (t :+-: tr) = t :+-: writeHListMElem @'TellableFlag x tr writeHListMElem x (t :-+: tr) = t :-+: writeHListMElem @'TellableFlag x tr writeHListMElem x (t :++: tr) = t :++: writeHListMElem @'TellableFlag x tr instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif HListMContains 'GettableFlag x ('Settable x ': tr) => HListMContains 'SettableFlag x ('Settable x ': tr) where readHListMElem (x :++: _) = x writeHListMElem x ts = case ts of (_ :++: tr) -> x :++: tr instance HListMContains 'SettableFlag x ts => HListMContains 'SettableFlag x (t ': ts) where readHListMElem (_ :+-: xr) = readHListMElem @'SettableFlag xr readHListMElem (_ :-+: xr) = readHListMElem @'SettableFlag xr readHListMElem (_ :++: xr) = readHListMElem @'SettableFlag xr writeHListMElem x (t :+-: tr) = t :+-: writeHListMElem @'SettableFlag x tr writeHListMElem x (t :-+: tr) = t :-+: writeHListMElem @'SettableFlag x tr writeHListMElem x (t :++: tr) = t :++: writeHListMElem @'SettableFlag x tr type family CanWriteConstraint (f :: CanReadWriteFlag) :: Constraint where CanWriteConstraint 'TellableFlag = () CanWriteConstraint 'SettableFlag = () data HListM :: [CanReadWrite Type] -> Type where HNilM :: HListM '[] (:+-:) :: x -> HListM xr -> HListM ('Gettable x ': xr) (:++:) :: x -> HListM xr -> HListM ('Settable x ': xr) (:-+:) :: x -> HListM xr -> HListM ('Tellable x ': xr) instance Semigroup (HListM '[]) where _ <> _ = HNilM instance Monoid (HListM '[]) where mempty = HNilM mappend = (<>) instance Eq (HListM '[]) where HNilM == HNilM = True HNilM /= HNilM = False instance (Eq x, Eq (HListM xs)) => Eq (HListM ('Gettable x ': xs)) where x1 :+-: xr1 == x2 :+-: xr2 = x1==x2 && xr1==xr2 x1 :+-: xr1 /= x2 :+-: xr2 = x1/=x2 || xr1/=xr2 instance (Eq x, Eq (HListM xs)) => Eq (HListM ('Tellable x ': xs)) where x1 :-+: xr1 == x2 :-+: xr2 = x1==x2 && xr1==xr2 x1 :-+: xr1 /= x2 :-+: xr2 = x1/=x2 || xr1/=xr2 instance (Eq x, Eq (HListM xs)) => Eq (HListM ('Settable x ': xs)) where x1 :++: xr1 == x2 :++: xr2 = x1==x2 && xr1==xr2 x1 :++: xr1 /= x2 :++: xr2 = x1/=x2 || xr1/=xr2 type family AppendM (l1 :: [CanReadWrite Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where AppendM '[] l2 = l2 AppendM (car1 ': cdr2) l2 = car1 ': AppendM cdr2 l2 type family HListMReaders (l :: [Type]) :: [CanReadWrite Type] where HListMReaders '[] = '[] HListMReaders (t ': tr) = 'Gettable t ': HListMReaders tr type family AppendMReaders (l1 :: [Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where AppendMReaders '[] l2 = l2 AppendMReaders (t ': tr) l2 = 'Gettable t ': AppendMReaders tr l2 class HListMGettableClass ts where type HListMGettableOnly ts :: [Type] hListMGettableOnly :: HListM ts -> HList.HList (HListMGettableOnly ts) instance HListMGettableClass '[] where type HListMGettableOnly '[] = '[] hListMGettableOnly HNilM = HList.HNil instance HListMGettableClass tr => HListMGettableClass ('Gettable t ': tr) where type HListMGettableOnly ('Gettable t ': tr) = (t ': HListMGettableOnly tr) hListMGettableOnly (t :+-: tr) = t HList.:+: hListMGettableOnly tr instance HListMGettableClass tr => HListMGettableClass ('Settable t ': tr) where type HListMGettableOnly ('Settable t ': tr) = HListMGettableOnly tr hListMGettableOnly (_ :++: tr) = hListMGettableOnly tr instance HListMGettableClass tr => HListMGettableClass ('Tellable t ': tr) where type HListMGettableOnly ('Tellable t ': tr) = HListMGettableOnly tr hListMGettableOnly (_ :-+: tr) = hListMGettableOnly tr multistate-0.8.0.4/src/Control/Monad/Trans/MultiGST/Lazy.hs0000644000000000000000000001752707346545000021540 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE FlexibleContexts #-} -- | Alternative multi-valued version of mtl's RWS / RWST. In contrast to -- @'MultiRWS'(T)@ this version only takes a single list of types as -- parameter, but with additional encoding of the allowed access for each -- element. This supports the @'MonadMultiGet'@ notion more succinctly, i.e. -- to pass a "state" element to a function that only requires/expects read/get -- access. This is not possible with 'MultiRWS'. module Control.Monad.Trans.MultiGST.Lazy ( MultiGSTT(..) , MultiGSTTNull , MultiGST -- * MonadMulti classes , ContainsReader , ContainsState , ContainsWriter , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiGet(..) , MonadMultiState(..) , CanReadWrite(..) -- * run-functions , runMultiGSTTNil , runMultiGSTTNil_ -- * with-functions , withReader , withReader_ , withReaders , withWriter , withWriterAW , withWriterWA , withWriterW , withState , withStateAS , withStateSA , withStateA , withStateS , withState_ -- * without-functions , without -- * other functions , mGetRaw , mSetRaw , mGetRawR , mapMultiGSTT ) where import Control.Monad.State.Lazy ( StateT(..) , MonadState(..) , execStateT , evalStateT , mapStateT ) import Data.Functor.Identity ( Identity ) import Control.Monad.Trans.Class ( MonadTrans , lift ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Applicative ( Applicative(..) , Alternative(..) ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Monoid ( Monoid , (<>) ) import GHC.Exts (Constraint) import Control.Monad.Trans.MultiReader.Class import Control.Monad.Trans.MultiWriter.Class import Control.Monad.Trans.MultiState.Class import qualified Data.HList.HList as HList import Control.Monad.Trans.MultiGST.Common newtype MultiGSTT ts m a = MultiGSTT { runMultiGSTTRaw :: StateT (HListM ts) m a } deriving(Functor, Applicative, Monad, MonadTrans, MonadIO, Alternative, MonadPlus) type MultiGSTTNull = MultiGSTT '[] type MultiGST r = MultiGSTT r Identity instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, HListMContains 'GettableFlag a cts) => MonadMultiGet a (MultiGSTT cts m) where mGet = MultiGSTT $ liftM (\ts -> readHListMElem @'GettableFlag ts) get instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, HListMContains 'SettableFlag a cts) => MonadMultiState a (MultiGSTT cts m) where mSet x = MultiGSTT $ do ts <- get put $ writeHListMElem @'SettableFlag x ts instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif ( Monad m , Monoid a , HListMContains 'TellableFlag a cts ) => MonadMultiWriter a (MultiGSTT cts m) where mTell x = MultiGSTT $ do ts <- get let x' = readHListMElem @'TellableFlag ts put $ writeHListMElem @'TellableFlag (x' <> x) ts runMultiGSTTNil :: Monad m => MultiGSTT '[] m a -> m a runMultiGSTTNil_ :: Monad m => MultiGSTT '[] m a -> m () runMultiGSTTNil k = evalStateT (runMultiGSTTRaw k) (HNilM) runMultiGSTTNil_ k = liftM (const ()) (evalStateT (runMultiGSTTRaw k) (HNilM)) withReader :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m a withReader x k = MultiGSTT $ do tr <- get ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) put $ case ts' of _ :+-: tr' -> tr' return a withReader_ :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m () withReader_ x k = MultiGSTT $ do tr <- get ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) put $ case ts' of _ :+-: tr' -> tr' withReaders :: Monad m => HList.HList rs -> MultiGSTT (AppendM (HListMReaders rs) ts) m a -> MultiGSTT ts m a withReaders HList.HNil = id withReaders (t HList.:+: ts) = withReaders ts . withReader t withWriter :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) withWriterAW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) withWriterWA :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (t, a) withWriterW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m t withWriter = withWriterAW withWriterAW k = MultiGSTT $ do tr <- get ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) case ts' of t :-+: tr' -> do put tr' return (a, t) withWriterWA k = MultiGSTT $ do tr <- get ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) case ts' of t :-+: tr' -> do put tr' return (t, a) withWriterW k = MultiGSTT $ do tr <- get ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) case ts' of t :-+: tr' -> do put tr' return t withState :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) withStateAS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) withStateSA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (t, a) withStateA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m a withStateS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m t withState_ :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m () withState = withStateAS withStateAS t k = MultiGSTT $ do tr <- get ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of t' :++: tr' -> do put tr' return (a, t') withStateSA t k = MultiGSTT $ do tr <- get ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of t' :++: tr' -> do put tr' return (t', a) withStateA t k = MultiGSTT $ do tr <- get ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of _ :++: tr' -> do put tr' return a withStateS t k = MultiGSTT $ do tr <- get ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of t' :++: tr' -> do put tr' return t' withState_ t k = MultiGSTT $ do tr <- get ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of _ :++: tr' -> do put tr' without :: Monad m => MultiGSTT tr m a -> MultiGSTT (ct ': tr) m a without k = MultiGSTT $ do ts <- get case ts of (t :+-: tr) -> do ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr put (t :+-: tr') return a (t :-+: tr) -> do ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr put (t :-+: tr') return a (t :++: tr) -> do ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr put (t :++: tr') return a mGetRaw :: Monad m => MultiGSTT ts m (HListM ts) mGetRaw = MultiGSTT get mGetRawR :: (Monad m, HListMGettableClass ts) => MultiGSTT ts m (HList.HList (HListMGettableOnly ts)) mGetRawR = MultiGSTT $ liftM hListMGettableOnly get mSetRaw :: Monad m => HListM ts -> MultiGSTT ts m () mSetRaw = MultiGSTT . put mapMultiGSTT :: (ts ~ HListM cts) => (m (a, ts) -> m' (a', ts)) -> MultiGSTT cts m a -> MultiGSTT cts m' a' mapMultiGSTT f = MultiGSTT . mapStateT f . runMultiGSTTRaw multistate-0.8.0.4/src/Control/Monad/Trans/MultiGST/Strict.hs0000644000000000000000000001605607346545000022065 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE FlexibleContexts #-} -- | Alternative multi-valued version of mtl's RWS / RWST. In contrast to -- @'MultiRWS'(T)@ this version only takes a single list of types as -- parameter, but with additional encoding of the allowed access for each -- element. This supports the @'MonadMultiGet'@ notion more succinctly, i.e. -- to pass a "state" element to a function that only requires/expects read/get -- access. This is not possible with 'MultiRWS'. module Control.Monad.Trans.MultiGST.Strict ( MultiGSTT(..) , MultiGSTTNull , MultiGST -- * MonadMulti classes , ContainsReader , ContainsState , ContainsWriter , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiGet(..) , CanReadWrite(..) -- * run-functions , runMultiGSTTNil , runMultiGSTTNil_ -- * with-functions , withReader , withReader_ , withWriter , withWriterAW , withWriterWA , withWriterW , withState , withStateAS , withStateSA , withStateA , withStateS , withState_ -- * without-functions , without -- * other functions , mGetRaw , mSetRaw , mapMultiGSTT ) where import Control.Monad.State.Strict ( StateT(..) , MonadState(..) , execStateT , evalStateT , mapStateT ) import Data.Functor.Identity ( Identity ) import Control.Monad.Trans.Class ( MonadTrans , lift ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Data.Monoid ( Monoid , (<>) ) import GHC.Exts (Constraint) import Control.Monad.Trans.MultiReader.Class import Control.Monad.Trans.MultiWriter.Class import Control.Monad.Trans.MultiState.Class import Control.Monad.Trans.MultiGST.Common newtype MultiGSTT ts m a = MultiGSTT { runMultiGSTTRaw :: StateT (HListM ts) m a } deriving(Functor, Applicative, Monad, MonadTrans) type MultiGSTTNull = MultiGSTT '[] type MultiGST r = MultiGSTT r Identity instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, HListMContains 'GettableFlag a cts) => MonadMultiGet a (MultiGSTT cts m) where mGet = MultiGSTT $ liftM (\ts -> readHListMElem @'GettableFlag ts) get instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, HListMContains 'SettableFlag a cts) => MonadMultiState a (MultiGSTT cts m) where mSet x = MultiGSTT $ do ts <- get put $ writeHListMElem @'SettableFlag x ts instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif ( Monad m , Monoid a , HListMContains 'TellableFlag a cts ) => MonadMultiWriter a (MultiGSTT cts m) where mTell x = MultiGSTT $ do ts <- get let x' = readHListMElem @'TellableFlag ts put $ writeHListMElem @'TellableFlag (x' <> x) ts runMultiGSTTNil :: Monad m => MultiGSTT '[] m a -> m a runMultiGSTTNil_ :: Monad m => MultiGSTT '[] m a -> m () runMultiGSTTNil k = evalStateT (runMultiGSTTRaw k) (HNilM) runMultiGSTTNil_ k = liftM (const ()) (evalStateT (runMultiGSTTRaw k) (HNilM)) withReader :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m a withReader x k = MultiGSTT $ do tr <- get (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) put $ case ts' of _ :+-: tr' -> tr' return a withReader_ :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m () withReader_ x k = MultiGSTT $ do tr <- get (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) put $ case ts' of _ :+-: tr' -> tr' withWriter :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) withWriterAW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) withWriterWA :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (t, a) withWriterW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m t withWriter = withWriterAW withWriterAW k = MultiGSTT $ do tr <- get (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) case ts' of t :-+: tr' -> do put tr' return (a, t) withWriterWA k = MultiGSTT $ do tr <- get (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) case ts' of t :-+: tr' -> do put tr' return (t, a) withWriterW k = MultiGSTT $ do tr <- get (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) case ts' of t :-+: tr' -> do put tr' return t withState :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) withStateAS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) withStateSA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (t, a) withStateA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m a withStateS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m t withState_ :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m () withState = withStateAS withStateAS t k = MultiGSTT $ do tr <- get (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of t' :++: tr' -> do put tr' return (a, t') withStateSA t k = MultiGSTT $ do tr <- get (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of t' :++: tr' -> do put tr' return (t', a) withStateA t k = MultiGSTT $ do tr <- get (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of _ :++: tr' -> do put tr' return a withStateS t k = MultiGSTT $ do tr <- get (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of t' :++: tr' -> do put tr' return t' withState_ t k = MultiGSTT $ do tr <- get (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) case ts' of _ :++: tr' -> do put tr' without :: Monad m => MultiGSTT tr m a -> MultiGSTT (ct ': tr) m a without k = MultiGSTT $ do ts <- get case ts of (t :+-: tr) -> do (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr put (t :+-: tr') return a (t :-+: tr) -> do (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr put (t :-+: tr') return a (t :++: tr) -> do (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr put (t :++: tr') return a mGetRaw :: Monad m => MultiGSTT ts m (HListM ts) mGetRaw = MultiGSTT get mSetRaw :: Monad m => HListM ts -> MultiGSTT ts m () mSetRaw = MultiGSTT . put mapMultiGSTT :: (ts ~ HListM cts) => (m (a, ts) -> m' (a', ts)) -> MultiGSTT cts m a -> MultiGSTT cts m' a' mapMultiGSTT f = MultiGSTT . mapStateT f . runMultiGSTTRaw multistate-0.8.0.4/src/Control/Monad/Trans/MultiGet/0000755000000000000000000000000007346545000020333 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiGet/Class.hs0000644000000000000000000000150307346545000021733 0ustar0000000000000000-- | The MonadMultiReader type-class module Control.Monad.Trans.MultiGet.Class ( -- * MonadMultiReader class MonadMultiGet(..) ) where import Control.Monad.Trans.Class ( MonadTrans , lift ) -- | In contrast to MonadMultiReader, MonadMultiGet is defined for State too, -- so it corresponds to read-access of any kind. -- -- Note however that for MultiRWS, only the values from the @state@ part can -- be accessed via @MonadMultiGet@, due to limitations of the design of -- @MultiRWS@ and of the type system. This is issue is resolved in the -- @MultiGST@ type. class (Monad m) => MonadMultiGet a m where mGet :: m a -- ^ Access to a specific type in the environment. instance (MonadTrans t, Monad (t m), MonadMultiGet a m) => MonadMultiGet a (t m) where mGet = lift $ mGet multistate-0.8.0.4/src/Control/Monad/Trans/MultiRWS.hs0000644000000000000000000000271207346545000020625 0ustar0000000000000000-- | The multi-valued version of mtl's RWS / RWST module Control.Monad.Trans.MultiRWS ( -- * MultiRWST MultiRWST(..) , MultiRWSTNull , MultiRWS -- * MonadMulti classes , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiGet(..) , MonadMultiState(..) -- * 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_ -- * without-functions (reducing an RWST; inverse of with) , withoutMultiReader , withoutMultiState -- * 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 multistate-0.8.0.4/src/Control/Monad/Trans/MultiRWS/0000755000000000000000000000000007346545000020267 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiRWS/Lazy.hs0000644000000000000000000004207307346545000021550 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 -- * MonadMulti classes , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiGet(..) , MonadMultiState(..) -- * 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_ -- * without-functions (reducing an RWST; inverse of with) , withoutMultiReader , withoutMultiState -- * 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 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) 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 = pure k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f instance MonadTrans (MultiRWST r w s) where lift = MultiRWST . lift instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, ContainsType a r) => MonadMultiReader a (MultiRWST r w s m) where mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (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 #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, ContainsType a s) => MonadMultiGet a (MultiRWST r w s m) where mGet = MultiRWST $ do ~(_,_,s) <- get return $ getHListElem s instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (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) instance MonadFix m => MonadFix (MultiRWST r w s m) where mfix f = MultiRWST $ mfix (runMultiRWSTRaw . f) -- 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 withoutMultiReader :: Monad m => MultiRWST rs w s m a -> MultiRWST (r ': rs) w s m a withoutMultiReader k = MultiRWST $ get >>= \case (rs@(_ :+: rr), w, s) -> do ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s) put (rs, w', s') return a withoutMultiState :: Monad m => MultiRWST r w ss m a -> MultiRWST r w (s ': ss) m a withoutMultiState k = MultiRWST $ get >>= \case (r, w, s :+: sr) -> do ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr) put (r, w', s :+: s') return a 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, MonadMultiState s (t m), MonadTrans t) => StateT s m a -> t 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 -- foreign lifting instances instance MonadIO m => MonadIO (MultiRWST r w s m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiRWST r w s m) where empty = lift mzero MultiRWST m <|> MultiRWST n = MultiRWST $ m <|> n instance MonadPlus m => MonadPlus (MultiRWST r w s m) where mzero = MultiRWST $ mzero MultiRWST m `mplus` MultiRWST n = MultiRWST $ m `mplus` n instance MonadBase b m => MonadBase b (MultiRWST r w s m) where liftBase = liftBaseDefault instance MonadTransControl (MultiRWST r w s) where type StT (MultiRWST r w s) a = (a, (HList r, HList w, HList s)) liftWith f = MultiRWST $ liftWith $ \s -> f $ \r -> s $ runMultiRWSTRaw r restoreT = MultiRWST . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiRWST r w s m) where type StM (MultiRWST r w s m) a = ComposeSt (MultiRWST r w s) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiRWS/Strict.hs0000644000000000000000000004210307346545000022073 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} -- | The multi-valued version of mtl's RWS / RWST module Control.Monad.Trans.MultiRWS.Strict ( -- * MultiRWST MultiRWST(..) , MultiRWSTNull , MultiRWS -- * MonadMulti classes , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiGet(..) , MonadMultiState(..) -- * 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_ -- * without-functions (reducing an RWST; inverse of with) , withoutMultiReader , withoutMultiState -- * 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 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) 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 = pure k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f instance MonadTrans (MultiRWST r w s) where lift = MultiRWST . lift instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, ContainsType a r) => MonadMultiReader a (MultiRWST r w s m) where mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, ContainsType a w, Monoid a) => MonadMultiWriter a (MultiRWST r w s m) where mTell v = MultiRWST $ do (r,w,s) <- get let !x' = getHListElem w `mappend` v put $ (r, setHListElem x' w, s) instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (Monad m, ContainsType a s) => MonadMultiGet a (MultiRWST r w s m) where mGet = MultiRWST $ do (_,_,s) <- get return $ getHListElem s instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (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) instance MonadFix m => MonadFix (MultiRWST r w s m) where mfix f = MultiRWST $ mfix (runMultiRWSTRaw . f) -- 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 withoutMultiReader :: Monad m => MultiRWST rs w s m a -> MultiRWST (r ': rs) w s m a withoutMultiReader k = MultiRWST $ get >>= \case (rs@(_ :+: rr), w, s) -> do (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s) put (rs, w', s') return a withoutMultiState :: Monad m => MultiRWST r w ss m a -> MultiRWST r w (s ': ss) m a withoutMultiState k = MultiRWST $ get >>= \case (r, w, s :+: sr) -> do (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr) put (r, w', s :+: s') return a 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, MonadTrans t, MonadMultiState s (t m)) => StateT s m a -> t 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 -- foreign lifting instances instance MonadIO m => MonadIO (MultiRWST r w s m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiRWST r w s m) where empty = lift mzero MultiRWST m <|> MultiRWST n = MultiRWST $ m <|> n instance MonadPlus m => MonadPlus (MultiRWST r w s m) where mzero = MultiRWST $ mzero MultiRWST m `mplus` MultiRWST n = MultiRWST $ m `mplus` n instance MonadBase b m => MonadBase b (MultiRWST r w s m) where liftBase = liftBaseDefault instance MonadTransControl (MultiRWST r w s) where type StT (MultiRWST r w s) a = (a, (HList r, HList w, HList s)) liftWith f = MultiRWST $ liftWith $ \s -> f $ \r -> s $ runMultiRWSTRaw r restoreT = MultiRWST . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiRWST r w s m) where type StM (MultiRWST r w s m) a = ComposeSt (MultiRWST r w s) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiReader.hs0000644000000000000000000000143207346545000021352 0ustar0000000000000000-- | 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_ -- * without-function (single reader) , withoutMultiReader -- * inflate-function (run ReaderT in MultiReaderT) , inflateReader -- * other functions , mapMultiReaderT , mGetRaw , mPutRaw ) where -- just re-export import Control.Monad.Trans.MultiReader.Lazy multistate-0.8.0.4/src/Control/Monad/Trans/MultiReader/0000755000000000000000000000000007346545000021016 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiReader/Class.hs0000644000000000000000000000352707346545000022426 0ustar0000000000000000-- | 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 $ getmultistate-0.8.0.4/src/Control/Monad/Trans/MultiReader/Lazy.hs0000644000000000000000000002042107346545000022270 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | The multi-valued version of mtl's Reader / ReaderT module Control.Monad.Trans.MultiReader.Lazy ( -- * MultiReaderT MultiReaderT(..) , MultiReaderTNull , MultiReader -- * MonadMultiReader class , MonadMultiReader(..) , MonadMultiGet(..) -- * run-functions , runMultiReaderT , runMultiReaderT_ , runMultiReaderTNil , runMultiReaderTNil_ -- * with-functions (single reader) , withMultiReader , withMultiReader_ -- * with-functions (multiple readers) , withMultiReaders , withMultiReaders_ -- * without-function (single reader) , withoutMultiReader -- * 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 import Control.Monad.Trans.MultiState.Class 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) -- | 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 = pure k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= runMultiReaderTRaw . f instance MonadTrans (MultiReaderT x) where lift = MultiReaderT . lift #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiReader a (MultiReaderT c m) where mAsk = MultiReaderT $ liftM getHListElem get #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiGet a (MultiReaderT c m) where mGet = MultiReaderT $ liftM getHListElem get instance MonadFix m => MonadFix (MultiReaderT r m) where mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) -- 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 withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a withoutMultiReader k = MultiReaderT $ get >>= \case (_ :+: rr) -> lift $ runMultiReaderT rr k 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 instance MonadIO m => MonadIO (MultiReaderT c m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiReaderT c m) where empty = lift mzero MultiReaderT m <|> MultiReaderT n = MultiReaderT $ m <|> n instance MonadPlus m => MonadPlus (MultiReaderT c m) where mzero = MultiReaderT $ mzero MultiReaderT m `mplus` MultiReaderT n = MultiReaderT $ m `mplus` n instance MonadBase b m => MonadBase b (MultiReaderT r m) where liftBase = liftBaseDefault instance MonadTransControl (MultiReaderT r) where type StT (MultiReaderT r) a = (a, HList r) liftWith f = MultiReaderT $ liftWith $ \s -> f $ \r -> s $ runMultiReaderTRaw r restoreT = MultiReaderT . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiReaderT r m) where type StM (MultiReaderT r m) a = ComposeSt (MultiReaderT r) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiReader/Strict.hs0000644000000000000000000002042107346545000022621 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | The multi-valued version of mtl's Reader / ReaderT module Control.Monad.Trans.MultiReader.Strict ( -- * MultiReaderT MultiReaderT(..) , MultiReaderTNull , MultiReader -- * MonadMultiReader class , MonadMultiReader(..) , MonadMultiGet(..) -- * run-functions , runMultiReaderT , runMultiReaderT_ , runMultiReaderTNil , runMultiReaderTNil_ -- * with-functions (single reader) , withMultiReader , withMultiReader_ -- * with-functions (multiple readers) , withMultiReaders , withMultiReaders_ -- * without-function (single reader) , withoutMultiReader -- * 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 import Control.Monad.Trans.MultiState.Class 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) -- | 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 = pure k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= (runMultiReaderTRaw . f) instance MonadTrans (MultiReaderT x) where lift = MultiReaderT . lift #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiReader a (MultiReaderT c m) where mAsk = MultiReaderT $ liftM getHListElem get #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiGet a (MultiReaderT c m) where mGet = MultiReaderT $ liftM getHListElem get instance MonadFix m => MonadFix (MultiReaderT r m) where mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) -- 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 withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a withoutMultiReader k = MultiReaderT $ get >>= \case (_ :+: rr) -> lift $ runMultiReaderT rr k 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 instance MonadIO m => MonadIO (MultiReaderT c m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiReaderT c m) where empty = lift mzero MultiReaderT m <|> MultiReaderT n = MultiReaderT $ m <|> n instance MonadPlus m => MonadPlus (MultiReaderT c m) where mzero = MultiReaderT $ mzero MultiReaderT m `mplus` MultiReaderT n = MultiReaderT $ m `mplus` n instance MonadBase b m => MonadBase b (MultiReaderT r m) where liftBase = liftBaseDefault instance MonadTransControl (MultiReaderT r) where type StT (MultiReaderT r) a = (a, HList r) liftWith f = MultiReaderT $ liftWith $ \s -> f $ \r -> s $ runMultiReaderTRaw r restoreT = MultiReaderT . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiReaderT r m) where type StM (MultiReaderT r m) a = ComposeSt (MultiReaderT r) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiState.hs0000644000000000000000000000210007346545000021221 0ustar0000000000000000-- | The multi-valued version of mtl's State / StateT -- / MonadState module Control.Monad.Trans.MultiState ( -- * MultiStateT MultiStateT(..) , MultiStateTNull , MultiState -- * MonadMultiState class , MonadMultiGet(..) , 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_ -- * without-function (single state) , withoutMultiState -- * 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.Lazy multistate-0.8.0.4/src/Control/Monad/Trans/MultiState/0000755000000000000000000000000007346545000020674 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiState/Class.hs0000644000000000000000000000130507346545000022274 0ustar0000000000000000-- | The multi-valued version of mtl's MonadState module Control.Monad.Trans.MultiState.Class ( -- * MonadMultiState class MonadMultiGet(..) , MonadMultiState(..) ) where import Control.Monad.Trans.MultiGet.Class import Control.Monad.Trans.Class ( MonadTrans , lift ) -- The idea is: Any monad stack is instance of @MonadMultiState a@, iff -- the stack contains a @MultiStateT s m@ with /a/ element of /s/, -- or a @MultiRWST r w s m@ with /a/ element of /s/. class (MonadMultiGet a m) => MonadMultiState a m where mSet :: a -> m () instance (MonadTrans t, Monad (t m), MonadMultiState a m) => MonadMultiState a (t m) where mSet = lift . mSet multistate-0.8.0.4/src/Control/Monad/Trans/MultiState/Lazy.hs0000644000000000000000000002661607346545000022162 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | The multi-valued version of mtl's State / StateT module Control.Monad.Trans.MultiState.Lazy ( -- * MultiStateT MultiStateT(..) , MultiStateTNull , MultiState -- * MonadMultiState class , MonadMultiGet(..) , 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_ -- * without-function (single state) , withoutMultiState -- * 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Data.Monoid ( Monoid ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) -- | 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 = pure k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) instance MonadTrans (MultiStateT x) where lift = MultiStateT . lift #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiGet a (MultiStateT c m) where mGet = MultiStateT $ liftM getHListElem get #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiState a (MultiStateT c m) where mSet v = MultiStateT $ get >>= put . setHListElem v instance MonadFix m => MonadFix (MultiStateT s m) where mfix f = MultiStateT $ mfix (runMultiStateTRaw . f) -- 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 withoutMultiState :: (Functor m, Monad m) => MultiStateT ss m a -> MultiStateT (s ': ss) m a withoutMultiState k = MultiStateT $ get >>= \case s :+: sr -> do ~(a, sr') <- lift $ runMultiStateT sr k put (s :+: sr') return a 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 instance MonadIO m => MonadIO (MultiStateT c m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiStateT s m) where empty = lift mzero MultiStateT m <|> MultiStateT n = MultiStateT $ m <|> n instance MonadPlus m => MonadPlus (MultiStateT s m) where mzero = MultiStateT $ mzero MultiStateT m `mplus` MultiStateT n = MultiStateT $ m `mplus` n instance MonadBase b m => MonadBase b (MultiStateT s m) where liftBase = liftBaseDefault instance MonadTransControl (MultiStateT s) where type StT (MultiStateT s) a = (a, HList s) liftWith f = MultiStateT $ liftWith $ \s -> f $ \r -> s $ runMultiStateTRaw r restoreT = MultiStateT . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiStateT s m) where type StM (MultiStateT s m) a = ComposeSt (MultiStateT s) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiState/Strict.hs0000644000000000000000000002654007346545000022507 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | The multi-valued version of mtl's State / StateT module Control.Monad.Trans.MultiState.Strict ( -- * MultiStateT MultiStateT(..) , MultiStateTNull , MultiState -- * MonadMultiState class , MonadMultiGet(..) , 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_ -- * without-function (single state) , withoutMultiState -- * 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.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 Control.Monad.Trans.MultiState.Class import Data.Functor.Identity ( Identity ) import Control.Applicative ( Applicative(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Data.Monoid ( Monoid ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) -- | 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 = pure k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) instance MonadTrans (MultiStateT x) where lift = MultiStateT . lift #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiGet a (MultiStateT c m) where mGet = MultiStateT $ liftM getHListElem get #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) #else instance (Monad m, ContainsType a c) #endif => MonadMultiState a (MultiStateT c m) where mSet v = MultiStateT $ get >>= put . setHListElem v instance MonadFix m => MonadFix (MultiStateT s m) where mfix f = MultiStateT $ mfix (runMultiStateTRaw . f) -- 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 withoutMultiState :: (Functor m, Monad m) => MultiStateT ss m a -> MultiStateT (s ': ss) m a withoutMultiState k = MultiStateT $ get >>= \case s :+: sr -> do (a, sr') <- lift $ runMultiStateT sr k put (s :+: sr') return a 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 instance MonadIO m => MonadIO (MultiStateT c m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiStateT s m) where empty = lift mzero MultiStateT m <|> MultiStateT n = MultiStateT $ m <|> n instance MonadPlus m => MonadPlus (MultiStateT s m) where mzero = MultiStateT $ mzero MultiStateT m `mplus` MultiStateT n = MultiStateT $ m `mplus` n instance MonadBase b m => MonadBase b (MultiStateT s m) where liftBase = liftBaseDefault instance MonadTransControl (MultiStateT s) where type StT (MultiStateT s) a = (a, HList s) liftWith f = MultiStateT $ liftWith $ \s -> f $ \r -> s $ runMultiStateTRaw r restoreT = MultiStateT . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiStateT s m) where type StM (MultiStateT s m) a = ComposeSt (MultiStateT s) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiWriter.hs0000644000000000000000000000147707346545000021435 0ustar0000000000000000{-# 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.Lazy multistate-0.8.0.4/src/Control/Monad/Trans/MultiWriter/0000755000000000000000000000000007346545000021070 5ustar0000000000000000multistate-0.8.0.4/src/Control/Monad/Trans/MultiWriter/Class.hs0000644000000000000000000000077107346545000022476 0ustar0000000000000000-- | 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 multistate-0.8.0.4/src/Control/Monad/Trans/MultiWriter/Lazy.hs0000644000000000000000000002305407346545000022347 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 -- * 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 -- * 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) 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 = pure k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw . f) instance MonadTrans (MultiWriterT x) where lift = MultiWriterT . lift #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c, Monoid a) #else instance (Monad m, ContainsType a c, Monoid a) #endif => MonadMultiWriter a (MultiWriterT c m) where mTell v = MultiWriterT $ do x <- get put $ setHListElem (getHListElem x `mappend` v) x instance MonadFix m => MonadFix (MultiWriterT w m) where mfix f = MultiWriterT $ mfix (runMultiWriterTRaw . f) -- 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 instance MonadIO m => MonadIO (MultiWriterT c m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiWriterT c m) where empty = lift mzero MultiWriterT m <|> MultiWriterT n = MultiWriterT $ m <|> n instance MonadPlus m => MonadPlus (MultiWriterT c m) where mzero = MultiWriterT $ mzero MultiWriterT m `mplus` MultiWriterT n = MultiWriterT $ m `mplus` n instance MonadBase b m => MonadBase b (MultiWriterT c m) where liftBase = liftBaseDefault instance MonadTransControl (MultiWriterT c) where type StT (MultiWriterT c) a = (a, HList c) liftWith f = MultiWriterT $ liftWith $ \s -> f $ \r -> s $ runMultiWriterTRaw r restoreT = MultiWriterT . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiWriterT c m) where type StM (MultiWriterT c m) a = ComposeSt (MultiWriterT c) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Control/Monad/Trans/MultiWriter/Strict.hs0000644000000000000000000002303307346545000022675 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 -- * 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 -- * 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(..) , Alternative(..) ) import Control.Monad ( MonadPlus(..) , liftM , ap , void ) import Control.Monad.Base ( MonadBase(..) , liftBaseDefault ) import Control.Monad.Trans.Control ( MonadTransControl(..) , MonadBaseControl(..) , ComposeSt , defaultLiftBaseWith , defaultRestoreM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) 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 = pure k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw.f) instance MonadTrans (MultiWriterT x) where lift = MultiWriterT . lift #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} (Monad m, ContainsType a c, Monoid a) #else instance (Monad m, ContainsType a c, Monoid a) #endif => MonadMultiWriter a (MultiWriterT c m) where mTell v = MultiWriterT $ do x <- get put $ setHListElem (getHListElem x `mappend` v) x instance MonadFix m => MonadFix (MultiWriterT w m) where mfix f = MultiWriterT $ mfix (runMultiWriterTRaw . f) -- 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 instance MonadIO m => MonadIO (MultiWriterT c m) where liftIO = lift . liftIO instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiWriterT c m) where empty = lift mzero MultiWriterT m <|> MultiWriterT n = MultiWriterT $ m <|> n instance MonadPlus m => MonadPlus (MultiWriterT c m) where mzero = MultiWriterT $ mzero MultiWriterT m `mplus` MultiWriterT n = MultiWriterT $ m `mplus` n instance MonadBase b m => MonadBase b (MultiWriterT c m) where liftBase = liftBaseDefault instance MonadTransControl (MultiWriterT c) where type StT (MultiWriterT c) a = (a, HList c) liftWith f = MultiWriterT $ liftWith $ \s -> f $ \r -> s $ runMultiWriterTRaw r restoreT = MultiWriterT . restoreT instance MonadBaseControl b m => MonadBaseControl b (MultiWriterT c m) where type StM (MultiWriterT c m) a = ComposeSt (MultiWriterT c) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM multistate-0.8.0.4/src/Data/HList/0000755000000000000000000000000007346545000014730 5ustar0000000000000000multistate-0.8.0.4/src/Data/HList/ContainsType.hs0000644000000000000000000000144007346545000017703 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Class to provide type-driven access to elements of a HList module Data.HList.ContainsType ( ContainsType(..) ) where import Data.HList.HList ---------------------------------------- -- class ContainsType -- | for get/put of a value in a HList, with type-directed lookup. class ContainsType a c where setHListElem :: a -> HList c -> HList c getHListElem :: HList c -> a #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} ContainsType a (a ': xs) where #else instance ContainsType a (a ': xs) where #endif 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 multistate-0.8.0.4/src/Data/HList/HList.hs0000644000000000000000000000520607346545000016312 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -- | A GADT HList implementation -- -- There exist other implementations of HList on hackage, but none seem to -- be reliably maintained. module Data.HList.HList ( HList(..) , Append , hAppend , HInit(..) ) where import Prelude hiding (reverse) import Data.Kind (Type) import Data.Monoid (Monoid, mappend, mempty) import Data.Semigroup import Data.Proxy data HList :: [Type] -> Type where HNil :: HList '[] (:+:) :: x -> HList xs -> HList (x ': xs) -- TCons :: x -> HList xs -> HList (Cons x xs) -- TNull :: HList Null infixr 5 :+: instance Show (HList '[]) where show _ = "HNil" instance (Show a, Show (HList b)) => Show (HList (a ': b)) where show (x :+: y) = "(" ++ show x ++ ":+:" ++ show y ++ ")" instance Semigroup (HList '[]) where _ <> _ = HNil instance (Semigroup x, Semigroup (HList xs)) => Semigroup (HList (x ': xs)) where (x1 :+: xs1) <> (x2 :+: xs2) = (x1 <> x2) :+: (xs1 <> xs2) instance Monoid (HList '[]) where mempty = HNil mappend = (<>) instance (Semigroup x, Monoid x, Semigroup (HList xs), Monoid (HList xs)) => Monoid (HList (x ': xs)) where mempty = mempty :+: mempty mappend = (<>) instance Eq (HList '[]) where HNil == HNil = True HNil /= HNil = False instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where x1 :+: xr1 == x2 :+: xr2 = x1==x2 && xr1==xr2 x1 :+: xr1 /= x2 :+: xr2 = x1/=x2 || xr1/=xr2 -- cannot use the closed variant because of ghc-7.8.4. -- (was not investigated more closely; there simply -- is some syntax error for code which works fine with ghc-7.10.) type family Append (l1::[Type]) (l2::[Type]) :: [Type] 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 :: [Type]) 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 #if !MIN_VERSION_base(4,9,0) hInit _ _ = error "cannot happen" -- see ghc trac #3927 #endif hSplit (x :+: xs) = let (l1, l2) = hSplit xs in (x :+: l1, l2) #if !MIN_VERSION_base(4,9,0) hSplit _ = error "cannot happen" #endif multistate-0.8.0.4/test/0000755000000000000000000000000007346545000013224 5ustar0000000000000000multistate-0.8.0.4/test/Test.hs0000644000000000000000000001607307346545000014506 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Main where import Data.Functor.Identity import Data.HList.HList import Data.Monoid import Data.Semigroup 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.runMultiStateTNil runEvalMR :: MR.MultiReaderT '[] Identity a -> a runEvalMR = runIdentity . MR.runMultiReaderTNil runExecMW :: Monoid (HList x) => MW.MultiWriterT x Identity a -> HList x runExecMW = runIdentity . MW.runMultiWriterTW runnerMS :: a -> MS.MultiStateT '[a] Identity a -> a 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 :: (Semigroup a, Monoid a) => MW.MultiWriterT '[a] Identity b -> a runnerMW m = case runExecMW m of (x :+: _) -> x -- TODO: ghc bug?: warning on: -- runnerMW m = case runExecMW m of (x :+: HNil) -> x runnerMS_ :: a -> MS.MultiStateT '[a] Identity b -> a runnerMS_ x m = runIdentity $ MS.runMultiStateTNil $ MS.withMultiStateA x (m >> MS.mGet) runnerMR_ :: a -> MR.MultiReaderT '[a] Identity b -> a runnerMR_ x m = runIdentity $ MR.runMultiReaderTNil $ MR.withMultiReader x (m >> MR.mAsk) intRunnerMS :: Int -> MS.MultiStateT '[Int] Identity Int -> Int intRunnerMS = runnerMS intRunnerMS_ :: Int -> MS.MultiStateT '[Int] Identity b -> Int intRunnerMS_ = runnerMS_ intRunnerMR :: Int -> MR.MultiReaderT '[Int] Identity Int -> Int intRunnerMR = runnerMR intRunnerMR_ :: Int -> MR.MultiReaderT '[Int] Identity b -> Int intRunnerMR_ = runnerMR_ stringRunnerMW :: MW.MultiWriterT '[String] Identity b -> String stringRunnerMW = runnerMW mrAskTuple :: ( Applicative m , MR.MonadMultiReader a m , MR.MonadMultiReader b m) => m (a,b) mrAskTuple = (,) <$> MR.mAsk <*> MR.mAsk msGetTuple :: ( Applicative m , MS.MonadMultiState a m , MS.MonadMultiState b m) => m (a,b) msGetTuple = (,) <$> MS.mGet <*> MS.mGet 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 :: 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 :: 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 :: Spec tests = do describe "MultiState" $ testsMultiState describe "MultiReader" $ testsMultiReader describe "MultiWriter" $ testsMultiWriter lazyStateTest test13MR :: Bool test13MR = runIdentity $ MR.runMultiReaderTNil $ MR.withMultiReader True $ MR.withMultiReader 'a' $ do c <- MR.mGetRaw return $ runIdentity $ MR.runMultiReaderTNil $ MR.withMultiReaders c $ do b <- MR.mAsk return (b::Bool) test13MS :: Bool test13MS = runIdentity $ MS.runMultiStateTNil $ MS.withMultiStateA True $ MS.withMultiStateA 'a' $ do c <- MS.mGetRaw return $ runIdentity $ 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) #if !MIN_VERSION_base(4,9,0) _ -> error "some ghc versions think that above is not exhaustive." #endif 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 = 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 (runMultiReaderT $ withConfig 'a' $ do x <- withConfig 'b' getConfig lift $ lift $ print (x::Char) y <- get lift $ lift $ print (y::Int) return () ) (1::Int) runMultiReaderT $ withConfig 'a' $ evalStateT ( do x <- getConfig lift $ lift $ print (x::Char) y <- get lift $ lift $ print (y::Int) return () ) (1::Int) main = do evalStateT (evalMultiStateT $ withConfig 'a' $ do x <- withConfig 'b' getConfig lift $ lift $ print (x::Char) y <- get lift $ lift $ print (y::Int) return () ) (1::Int) evalMultiStateT $ withConfig 'a' $ evalStateT ( do x <- getConfig lift $ lift $ print (x::Char) y <- get lift $ lift $ print (y::Int) return () ) (1::Int) -}