├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── changelog.md ├── default.nix ├── example └── Example.hs ├── iridium.yaml ├── multistate.cabal ├── nix └── README.md ├── seaaye.nix ├── shell.nix ├── src ├── Control │ └── Monad │ │ └── Trans │ │ ├── MultiGST.hs │ │ ├── MultiGST │ │ ├── Common.hs │ │ ├── Lazy.hs │ │ └── Strict.hs │ │ ├── MultiGet │ │ └── Class.hs │ │ ├── MultiRWS.hs │ │ ├── MultiRWS │ │ ├── Lazy.hs │ │ └── Strict.hs │ │ ├── MultiReader.hs │ │ ├── MultiReader │ │ ├── Class.hs │ │ ├── Lazy.hs │ │ └── Strict.hs │ │ ├── MultiState.hs │ │ ├── MultiState │ │ ├── Class.hs │ │ ├── Lazy.hs │ │ └── Strict.hs │ │ ├── MultiWriter.hs │ │ └── MultiWriter │ │ ├── Class.hs │ │ ├── Lazy.hs │ │ └── Strict.hs └── Data │ └── HList │ ├── ContainsType.hs │ └── HList.hs ├── stack-8.10.yaml ├── stack-8.6.yaml ├── stack-8.8.yaml ├── stack-9.0.yaml └── test └── Test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .cabal-sandbox/ 4 | cabal.sandbox.config 5 | README.pdf 6 | .stack-work/ 7 | .ghc.environment.* 8 | cabal.project.local 9 | /result* 10 | /nix/seaaye-cache 11 | /nix/gcroots 12 | /nix/ci-out 13 | /seaaye-local.nix 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Do not choose a language; we provide our own build tools. 5 | language: generic 6 | 7 | matrix: 8 | include: 9 | - env: GHCVER=8.0.2 CABALVER=1.24 10 | compiler: ": #cabal 8.0.2" 11 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} 12 | - env: GHCVER=8.2.2 CABALVER=1.24 13 | compiler: ": #cabal 8.2.2" 14 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2], sources: [hvr-ghc]}} 15 | - env: GHCVER=8.4.4 CABALVER=1.24 16 | compiler: ": #cabal 8.4.4" 17 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.4], sources: [hvr-ghc]}} 18 | - env: GHCVER=8.6.5 CABALVER=1.24 19 | compiler: ": #cabal 8.6.5" 20 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.5], sources: [hvr-ghc]}} 21 | - env: GHCVER=head CABALVER=head 22 | compiler: ": #cabal HEAD" 23 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 24 | 25 | allow_failures: 26 | - env: GHCVER=head CABALVER=head 27 | 28 | before_install: 29 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 30 | - travis_retry sudo apt-get update 31 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER 32 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 33 | # Uncomment whenever hackage is down. 34 | # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update 35 | - cabal update 36 | 37 | install: 38 | - cabal --version 39 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 40 | - travis_retry cabal update 41 | - cabal install --only-dependencies --enable-tests --enable-benchmarks 42 | 43 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 44 | script: 45 | - if [ -f configure.ac ]; then autoreconf -i; fi 46 | - cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-Werror" # -v2 provides useful information for debugging 47 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 48 | - cabal test 49 | - cabal check 50 | - cabal sdist # tests that a source-distribution can be generated 51 | 52 | # Check that the resulting source distribution can be built & installed. 53 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 54 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 55 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 56 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2013-2014 Jan Bracker 2 | Copyright 2013-2017 Lennart Spitzner 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, 9 | this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | * The names of this library's contributors may not be used to endorse or 14 | promote products derived from this software without specific prior 15 | written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 21 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 22 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 23 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 24 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 25 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 26 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 27 | POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # multistate 2 | 3 | [![Build Status](https://secure.travis-ci.org/lspitzner/multistate.svg)](http://travis-ci.org/lspitzner/multistate) 4 | [![Hackage](https://img.shields.io/hackage/v/multistate.svg)](https://hackage.haskell.org/package/multistate) 5 | 6 | ## Introduction 7 | 8 | When using multiple Reader/Writer/State transformers in the same monad 9 | stack, it becomes necessary to lift the operations in order to affect a 10 | specific transformer. 11 | Using heterogeneous lists (and all kinds of GHC extensions magic), 12 | this package provides transformers that remove that necessity: 13 | MultiReaderT/MultiWriterT/MultiStateT can contain a heterogeneous 14 | list of values. 15 | 16 | The type inferred for the getter/setter determines which value is 17 | read/written. 18 | 19 | ## Example 20 | 21 | ~~~~ 22 | simpleExample :: IO () 23 | simpleExample = runMultiStateTNil_ -- start with an empty state, 24 | -- i.e. :: MultiStateT '[] IO 25 | $ withMultiStateA 'H' -- "adding" a char to the state 26 | $ withMultiStateA "ello, World!" -- and a string 27 | $ do -- so: 28 | -- the monad here is MultiStateT '[String, Char] IO 29 | let combinedPrint = do -- no type signature necessary 30 | c <- mGet -- type of mGet inferred to be m Char 31 | cs <- mGet -- inferred to be m String 32 | lift $ putStrLn (c:cs) 33 | combinedPrint 34 | mSet 'J' -- we modify the Char in the state. 35 | -- again, the type is inferred, 36 | -- without any manual lifting. 37 | combinedPrint 38 | ~~~~ 39 | 40 | The output is: 41 | 42 | ~~~~ 43 | Hello, World! 44 | Jello, World! 45 | ~~~~ 46 | 47 | ( you can find both this and a more complex example 48 | in an executable in the package. ) 49 | 50 | ## Error Messages 51 | 52 | If you try to execute an action that requires a specific type in the state, 53 | but the current state does not contain that type, the error message is 54 | something like 55 | 56 | ~~~~ 57 | No instance for (Control.Monad.MultiState.ContainsType Foo '[]) x 58 | ~~~~ 59 | 60 | where `Foo` is the missing type. 61 | 62 | ## Compatibility with Single-Valued Transformers 63 | 64 | It is possible to run single-valued actions inside multi-valued 65 | transformers using the `inflate` functions. A function transforming 66 | a multi-valued transformer with exactly one element into a 67 | single-valued transformer would be trivial, but it is currently not provided. 68 | 69 | ## Naming Scheme 70 | 71 | (Will refer to StateT in this paragraph, but equally valid for Reader/Writer) 72 | The mtl monad transformers make use of primarily three methods to "unwrap" 73 | a transformed value: 74 | `runStateT`, `evalStateT`, `execStateT`. These three all have a type 75 | matching the pattern `s -> t m a -> m b`, they differ in what `b` is. 76 | We will use a different naming scheme, for three reasons: 77 | 78 | 1) "run", "eval" and "exec" are not in any way intuitive, and should be 79 | suffixed in any case. 80 | 81 | 2) For MultiStateT, it makes sense to transform an existing transformer, 82 | adding another state. The signature would be close to that of runStateT, 83 | only without the unwrapping part, i.e. `s -> t m a -> t' m b`, where `s` 84 | is the initial state, and `t` is `t'` with another state added. 85 | 86 | 3) Sometimes you might want to add/run a single state, or a bunch of them. 87 | For example, when running an arbitrary StateT, you would need to provide 88 | a HList of initial states, and would receive a HList of final states. 89 | 90 | Our naming scheme will instead be: 91 | 92 | 1) `runStateT.*` unwraps a StateT. A suffix controls 93 | what exactly is returned by the function. There is a special version for 94 | when the list of states is Nil, `runStateTNil`. 95 | 96 | 2) `withStateT.*` adds one or more states to a subcomputation. A suffix 97 | controls the exact return value. 98 | 99 | ~~~~ 100 | withStates 101 | /-------------------------------------------------------\ 102 | | withState withState .. withState v 103 | StateT '[s, ..] m --------> StateT '[..] m --------> .. --------> StateT '[] m 104 | | <-------- | 105 | | (withoutState) | 106 | | | 107 | | | 108 | | runStateT runStateTNil | 109 | \--------------------> m .. <---------------------------/ 110 | ~~~~ 111 | 112 | Specific functions are (constraints omitted): 113 | 114 | ~~~~ 115 | runMultiStateT = runMultiStateTAS 116 | runMultiStateTA :: HList s -> MultiStateT s m a -> m a 117 | runMultiStateTAS :: HList s -> MultiStateT s m a -> m (a, s) 118 | runMultiStateTSA :: HList s -> MultiStateT s m a -> m (s, a) 119 | runMultiStateTS :: HList s -> MultiStateT s m a -> m s 120 | runMultiStateT_ :: HList s -> MultiStateT s m a -> m () 121 | 122 | runMultiStateTNil :: MultiStateT '[] m a -> m a 123 | runMultiStateTNil_ :: MultiStateT '[] m a -> m () 124 | 125 | withMultiState = withMultiStateAS 126 | withMultiStateA :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m a 127 | withMultiStateAS :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) 128 | withMultiStateSA :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (s, a) 129 | withMultiStateS :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m s 130 | withMultiState_ :: s -> MultiStateT (s ': ss) m a -> MultiStateT ss m () 131 | 132 | withMultiStates = withMultiStatesAS 133 | withMultiStatesAS :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) 134 | withMultiStatesSA :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1, a) 135 | withMultiStatesA :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m a 136 | withMultiStatesS :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1) 137 | withMultiStates_ :: HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m () 138 | 139 | withoutMultiState :: MultiStateT ss m a -> MultiStateT (s ': ss) m a 140 | ~~~~ 141 | 142 | ## Known Deficits 143 | 144 | This package currently lacks a complete set of "lifting instances", i.e. 145 | instance definitions for classes such as mtl's MonadWriter "over" the newly 146 | introduced monad transformers, as in 147 | 148 | ~~~~ 149 | instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where .. 150 | ~~~~ 151 | 152 | These "lifting instances" would be necessary 153 | to achieve full compatibility with existing transformers. Ping me if you 154 | find anything specific missing. 155 | 156 | ## Changelog 157 | 158 | See changelog.md 159 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog for [`multistate` package](https://hackage.haskell.org/package/multistate) 2 | 3 | ## 0.8.0.4 *January 2022* 4 | 5 | * Adapt for ghc-9.0 and ghc-9.2 6 | * Clean up code a bit, fix compiler warnings (thanks sergv) 7 | 8 | ## 0.8.0.3 *May 2020* 9 | 10 | * Adapt for ghc-8.10 11 | * Add nix-expressions for testing against different ghc versions 12 | * Drop support for ghc < 8.4 13 | 14 | ## 0.8.0.2 *June 2019* 15 | 16 | * Adapt for ghc-8.8 (optimistically; QuickCheck does not build so 17 | tests are untested) 18 | 19 | ## 0.8.0.1 *October 2018* 20 | 21 | * Adapt for ghc-8.6 (really, this time) 22 | * Make package -Wcompat-ible 23 | 24 | ## 0.8.0.0 *April 2018* 25 | 26 | * Adapt for ghc-8.4 27 | * Drop support for ghc<8.0 28 | * Add class `MonadMultiGet` that roughly translates to "any read access" 29 | (instances for Reader and State) 30 | * Add data-type `MultiGST` that has a single taggified HList instead of the 31 | three r, w, s lists with `MultiRWS` 32 | 33 | ## 0.7.1.2 *August 2017* 34 | 35 | * Adapt for ghc-8.2 36 | 37 | * Minor strictness fix for MultiRWS 38 | 39 | ## 0.7.1.1 *May 2016* 40 | 41 | * Adapt for ghc-8 42 | 43 | ## 0.7.1.0 *March 2016* 44 | 45 | * Add new method `withoutMultiFoo`, inverse of `withMultiFoo` 46 | 47 | ## 0.7.0.0 *February 2016* 48 | 49 | * Add instances: 50 | 51 | + MonadIO 52 | + Alternative 53 | + MonadPlus 54 | + MonadBase 55 | + MonadTransControl 56 | + MonadBaseControl 57 | 58 | ## 0.6.2.0 *June 2015* 59 | 60 | * Add MonadFix instances 61 | 62 | ## 0.6.1.0 *June 2015* 63 | 64 | * Export classes from transformer modules 65 | 66 | ## 0.6.0.0 *June 2015* 67 | 68 | * Add `MultiRWST` 69 | 70 | * Add inflate functions (e.g. `StateT _ -> MultiStateT _`) 71 | 72 | * Improve lazyness 73 | 74 | * Move changelog from `README.md` to `changelog.md` 75 | 76 | ## 0.5.0.0 *March 2015* 77 | 78 | * Breaking changes (!): 79 | 80 | Refactor some parts of the interface, see "naming scheme" in the README; 81 | The changes are: 82 | 83 | | old | new | 84 | | --- | --- | 85 | | `withMultiFoo` | `withMultiFooA` | 86 | | `withMultiFoos` | `withMultiFoosA` | 87 | | `mAskRaw` | `mGetRaw` | 88 | | | `mPutRaw` | 89 | | `evalMultiStateT` | `runMultiStateTNil` | 90 | | `evalMultiStateTWithInitial` | `runMultiStateTA` | 91 | | `evalMultiReaderT` | `runMultiReaderTNil` | 92 | | `evalMultiReaderTWithInitial` | `runMultiReaderTA` | 93 | | `execMultiWriterT` | `runMultiWriterTW` | 94 | 95 | * Start using hspec; Add proper cabal test-suite. 96 | 97 | ## 0.4.0.0: *March 2015* 98 | 99 | * Refactor from `Control.Monad.*` to `Control.Monad.Trans.*` 100 | 101 | * Put classes (`MonadMulti*`) into separate modules 102 | 103 | * Add Strict and Lazy variants 104 | 105 | * Deprecate previous modules 106 | 107 | ## 0.3.0.0 *January 2015* 108 | 109 | * Add `MultiWriter` 110 | 111 | * Fixity for `(:+:)` 112 | 113 | * support ghc-7.10 114 | 115 | ## 0.2.0.0 *January 2015* 116 | 117 | * Start using DataKinds and TypeOperators to make the HList 118 | representation more readable. The translation roughly is: 119 | 120 | > ~~~~ 121 | > Null -> '[] 122 | > Cons a Null -> '[a] 123 | > Cons a b -> a ': b 124 | > TNull -> HNil 125 | > TCons a b -> a :+: b 126 | > ~~~~ 127 | 128 | * Remove dependency on `tfp` package. 129 | 130 | ## 0.1.3.2 *September 2014* 131 | 132 | * Add example 133 | 134 | * Clean up / Add dependencies 135 | 136 | * More documentation 137 | 138 | ## 0.1.2 *September 2014* 139 | 140 | * Expose `HList` module 141 | 142 | * Add haddocks 143 | 144 | ## 0.1.1 *June 2014* 145 | 146 | * First version published on hackage 147 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ./nix/all.nix).default.multistate -------------------------------------------------------------------------------- /example/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Main where 7 | 8 | 9 | 10 | import Control.Monad.Trans.MultiState 11 | 12 | import Control.Applicative ( (<$>), (<*>) ) 13 | 14 | import Control.Monad.Trans ( lift ) 15 | import Control.Monad.Writer 16 | 17 | 18 | 19 | {- 20 | Small example showing 21 | 1) a MultiState containing a Char and a String, 22 | 2) the polymorphic mGet, 23 | 3) how to initially put values into the MultiState using withMultiState, 24 | 4) the type inference at work - note that there was no need to annotate 25 | combinedPrint 26 | -} 27 | 28 | simpleExample :: IO () 29 | simpleExample = runMultiStateTNil_ 30 | $ withMultiState 'H' -- add a Char to the state 31 | $ withMultiState "ello, World!" -- add a String to the state 32 | $ do 33 | -- the monad here is MultiStateT '[String, Char] IO 34 | let combinedPrint = do 35 | c <- mGet 36 | cs <- mGet 37 | -- i <- mGet -- No instance for (Control.Monad.MultiState.ContainsType Int '[]) 38 | -- lift $ print $ (i :: Int) 39 | lift $ putStrLn (c:cs) 40 | combinedPrint 41 | mSet 'J' -- we set the Char in the state to 'J' 42 | combinedPrint 43 | 44 | -- output: 45 | -- "Hello, World! 46 | -- Jello, World! 47 | -- " 48 | 49 | -- and a more complex example: 50 | 51 | newtype Account = Account Float 52 | newtype Interest = Interest Float 53 | 54 | setAccount :: MonadMultiState Account m => Float -> m () 55 | setAccount x = mSet (Account x) 56 | getAccount :: MonadMultiState Account m => m Float 57 | getAccount = do 58 | (Account x) <- mGet 59 | return x 60 | modAccount :: MonadMultiState Account m => (Float -> Float) -> m () 61 | modAccount f = do 62 | (Account x) <- mGet 63 | mSet (Account (f x)) 64 | 65 | -- wait for a specific time, changing the account according to interest 66 | wait :: ( MonadMultiState Account m 67 | , MonadMultiState Interest m ) 68 | => Float 69 | -> m () 70 | wait t = do 71 | (Interest i) <- mGet 72 | (Account x) <- mGet 73 | mSet (Account (x*(1+i)**t)) 74 | 75 | logAccount :: ( MonadWriter [String] m 76 | , MonadMultiState Account m) 77 | => m () 78 | logAccount = do 79 | (Account x) <- mGet 80 | tell $ ["account balance = " ++ show x] 81 | 82 | accountCalculation :: Writer [String] () 83 | accountCalculation = runMultiStateTNil_ $ do 84 | tell ["account calculation start"] 85 | -- we cannot use any of the account methods here, because state is empty 86 | -- logAccount 87 | -- --> 88 | -- No instance for (Control.Monad.MultiState.ContainsType Account '[]) 89 | withMultiState (Account 0.0) $ do -- state contains an Account. 90 | logAccount 91 | modAccount (+10.0) 92 | logAccount 93 | -- trying to use "wait" here would give type error, like above. 94 | withMultiState (Interest 0.03) $ do -- state now also contains Interest. 95 | wait 10.0 -- we can use wait, because state contains all 96 | -- necessary stuff. 97 | logAccount 98 | modAccount (\x -> x - 10.0) 99 | wait 10.0 100 | logAccount 101 | mSet (Interest 0.00) 102 | wait 10.0 103 | -- we can return back to the environment without interest 104 | -- but the changes to the account are still present 105 | logAccount 106 | -- and we can return to an empty state 107 | tell ["account calculation end"] 108 | 109 | main = do 110 | simpleExample 111 | mapM_ putStrLn $ execWriter accountCalculation 112 | 113 | 114 | -- whatIsNotPossible :: MultiStateT '[String] IO () 115 | -- whatIsNotPossible = mGet >>= (lift . print) -- type ambiguous 116 | 117 | -- another thing that is not directly possible is the restriction to 118 | -- specific values, i.e. a function 119 | -- restrict :: MultiStateT xvalues m a -> MultiStateT yvalues m a 120 | -- where yvalues is a "superset" of xvalues. 121 | 122 | --TODO: example with mGetRaw and withMultiStates 123 | -------------------------------------------------------------------------------- /iridium.yaml: -------------------------------------------------------------------------------- 1 | # see https://github.com/lspitzner/iridium 2 | 3 | --- 4 | setup: 5 | buildtool: cabal # cannot be changed; stack is not supported (yet). 6 | 7 | # cabal-command: cabal 8 | # hlint-command: $HOME/.cabal/bin/hlint 9 | 10 | # This currently only checks that uploads happen to that remote, 11 | # it does not change the remote if a different one is configured. 12 | # (because that would require modifying `.cabal/config`,) 13 | remote-server: http://hackage.haskell.org 14 | 15 | process: 16 | dry-run: False # only run all checks/tests, omit any side-effects/uploading 17 | 18 | display-help: True 19 | 20 | # build docs locally and upload them instead of trusting the 21 | # docs builder which gets broken every two months. 22 | # implies the documentation check. 23 | upload-docs: True 24 | 25 | print-summary: True 26 | 27 | # confirm-always always ask for confirmation. 28 | # confirm-on-warning don't ask for confirmation if everything is clear. 29 | # confirm-on-error only ask for confirmation if there are errors. 30 | confirmation: confirm-always 31 | 32 | checks: 33 | hlint: 34 | enabled: False 35 | testsuites: 36 | enabled: True 37 | compiler-warnings: 38 | enabled: True 39 | enable-compat: True 40 | # whitelist: [only, these, tests] # not supported yet 41 | # blacklist: [omit, these, tests] # not supported yet 42 | # if you are completely unlucky, this might _overwrite_ 43 | # an existing cabal.config. if you press ctrl-c in exactly 44 | # the right moment or something. 45 | upper-bounds-stackage: 46 | # for existing upper bounds 47 | enabled: False 48 | use-nightly: True 49 | # blacklist: [omit, check, for, these, packages] # not supported yet 50 | upper-bounds-exist: 51 | enabled: True 52 | changelog: 53 | enabled: True 54 | location: changelog.md 55 | compiler-versions: 56 | enabled: True 57 | # for this to work, cabal will need the paths to the actual 58 | # compilers to be configured; see the note about the user-global 59 | # config above. 60 | compilers: 61 | - compiler: ghc 62 | version: 8.0.2 63 | - compiler: ghc 64 | version: 8.2.2 65 | - compiler: ghc 66 | version: 8.4.4 67 | - compiler: ghc 68 | version: 8.6.5 69 | # - compiler: ghc 70 | # version: 8.8.1-alpha1 71 | documentation: 72 | enabled: True 73 | 74 | repository: 75 | type: git # none | git 76 | git: 77 | display-current-branch: True 78 | release-tag: 79 | enabled: True 80 | content: "$VERSION" 81 | # NOT YET SUPPORTED 82 | # params: [] 83 | push-remote: 84 | # push the current branch (and the tag, if configured) to 85 | # a remote repo. 86 | enabled: True 87 | # the "remote" configured in git to push the release/tag to. 88 | remote-name: "origin" 89 | ... 90 | -------------------------------------------------------------------------------- /multistate.cabal: -------------------------------------------------------------------------------- 1 | Name: multistate 2 | Version: 0.8.0.4 3 | Cabal-Version: >= 1.10 4 | Build-Type: Simple 5 | license: BSD3 6 | license-file: LICENSE 7 | Copyright: Copyright (C) 2013 Jan Bracker, 2013-2020 Lennart Spitzner 8 | Maintainer: Lennart Spitzner 9 | Author: Jan Bracker, Lennart Spitzner 10 | Homepage: https://github.com/lspitzner/multistate 11 | Bug-reports: https://github.com/lspitzner/multistate/issues 12 | Stability: Experimental 13 | category: Control 14 | 15 | Synopsis: like mtl's ReaderT / WriterT / StateT, but more than one 16 | contained value/type. 17 | Description: 18 | When using multiple Read\/Write\/State transformers in the same monad stack, 19 | it becomes necessary to lift the operations in order to affect a specific 20 | transformer. 21 | Using heterogeneous lists (and all kinds of GHC extensions magic), 22 | this package provides transformers that remove that necessity: 23 | MultiReaderT\/MultiWriterT\/MultiStateT\/MultiRWST can contain a 24 | heterogeneous list of values. 25 | . 26 | See the for 27 | a longer description. 28 | 29 | extra-source-files: 30 | README.md 31 | changelog.md 32 | 33 | source-repository head { 34 | type: git 35 | location: git@github.com:lspitzner/multistate.git 36 | } 37 | 38 | flag build-example 39 | description: Build the MultiState-example example program 40 | default: False 41 | manual: True 42 | 43 | library { 44 | default-language: 45 | Haskell2010 46 | exposed-modules: 47 | Data.HList.HList 48 | Data.HList.ContainsType 49 | Control.Monad.Trans.MultiGet.Class 50 | Control.Monad.Trans.MultiReader 51 | Control.Monad.Trans.MultiReader.Class 52 | Control.Monad.Trans.MultiReader.Lazy 53 | Control.Monad.Trans.MultiReader.Strict 54 | Control.Monad.Trans.MultiWriter 55 | Control.Monad.Trans.MultiWriter.Class 56 | Control.Monad.Trans.MultiWriter.Lazy 57 | Control.Monad.Trans.MultiWriter.Strict 58 | Control.Monad.Trans.MultiState 59 | Control.Monad.Trans.MultiState.Class 60 | Control.Monad.Trans.MultiState.Lazy 61 | Control.Monad.Trans.MultiState.Strict 62 | Control.Monad.Trans.MultiRWS 63 | Control.Monad.Trans.MultiRWS.Lazy 64 | Control.Monad.Trans.MultiRWS.Strict 65 | Control.Monad.Trans.MultiGST 66 | Control.Monad.Trans.MultiGST.Lazy 67 | Control.Monad.Trans.MultiGST.Strict 68 | other-modules: 69 | Control.Monad.Trans.MultiGST.Common 70 | build-depends: 71 | base >= 4.11 && <4.17, 72 | mtl >= 2.1 && <2.3, 73 | transformers >= 0.3 && <0.6, 74 | tagged >= 0.7 && <0.9, 75 | transformers-base <0.5, 76 | monad-control >= 1.0 && <1.1 77 | default-extensions: 78 | GADTs 79 | TypeFamilies 80 | MultiParamTypeClasses 81 | FunctionalDependencies 82 | FlexibleContexts 83 | FlexibleInstances 84 | UndecidableInstances 85 | TypeOperators 86 | DataKinds 87 | LambdaCase 88 | ghc-options: { 89 | -Wall 90 | -Wcompat 91 | -fno-warn-unused-imports 92 | -fno-warn-redundant-constraints 93 | } 94 | hs-source-dirs: src 95 | } 96 | 97 | test-suite multistate-test { 98 | type: exitcode-stdio-1.0 99 | default-language: Haskell2010 100 | buildable: True 101 | build-depends: 102 | -- no version constraints necessary, because they are already 103 | -- given by library 104 | multistate, 105 | base <999, 106 | transformers <0.6, 107 | hspec >=2 && <2.9 108 | ghc-options: -Wall 109 | main-is: Test.hs 110 | hs-source-dirs: test 111 | } 112 | 113 | executable multistate-example { 114 | default-language: 115 | Haskell2010 116 | if flag(build-example) { 117 | buildable: True 118 | build-depends: 119 | -- no version constraints necessary, because they are already 120 | -- given by library 121 | multistate, 122 | base <999, 123 | mtl <2.3, 124 | transformers <0.6 125 | } else { 126 | buildable: False 127 | } 128 | main-is: Example.hs 129 | hs-source-dirs: example 130 | } 131 | -------------------------------------------------------------------------------- /nix/README.md: -------------------------------------------------------------------------------- 1 | 2 | This project uses the https://github.com/lspitzner/seaaye tool to build via 3 | nix. Please refer to its documentation for detailed help. 4 | 5 | For basic usage, running `seaaye shell` should drop you in a nix-shell 6 | to start developing/maintaining. `seaaye ci` will run a full check 7 | against multiple targets, but that _will_ need to compile certain ghcs 8 | that are not available in iohk's binary caches. 9 | 10 | Speaking of which, as seaaye is using iohk's "haskell.nix" toolkit, you 11 | probably want to set up the relevant binary caches for your nix installation. 12 | 13 | See https://input-output-hk.github.io/haskell.nix/iohk-nix/ 14 | -------------------------------------------------------------------------------- /seaaye.nix: -------------------------------------------------------------------------------- 1 | { seaaye-spec = 1; 2 | package-name = "multistate"; 3 | targets = 4 | { 5 | hackage-8-06 = { 6 | resolver = "hackage"; 7 | index-state = "2021-07-01T00:00:00Z"; 8 | ghc-ver = "ghc865"; 9 | }; 10 | hackage-8-08 = { 11 | resolver = "hackage"; 12 | index-state = "2021-07-01T00:00:00Z"; 13 | ghc-ver = "ghc884"; 14 | }; 15 | hackage-8-10 = { 16 | resolver = "hackage"; 17 | index-state = "2021-07-01T00:00:00Z"; 18 | ghc-ver = "ghc8107"; 19 | }; 20 | hackage-9-01 = { 21 | resolver = "hackage"; 22 | index-state = "2021-07-01T00:00:00Z"; 23 | ghc-ver = "ghc901"; 24 | }; 25 | hackage-9-02 = { 26 | resolver = "hackage"; 27 | index-state = "2021-11-01T00:00:00Z"; 28 | ghc-ver = "ghc921"; 29 | }; 30 | stackage-8-06 = { 31 | resolver = "stackage"; 32 | stackFile = "stack-8.6.yaml"; 33 | ghc-ver = "ghc865"; 34 | }; 35 | stackage-8-08 = { 36 | resolver = "stackage"; 37 | stackFile = "stack-8.8.yaml"; 38 | ghc-ver = "ghc884"; 39 | }; 40 | stackage-8-10 = { 41 | resolver = "stackage"; 42 | stackFile = "stack-8.10.yaml"; 43 | ghc-ver = "ghc8107"; 44 | }; 45 | stackage-9-01 = { 46 | resolver = "stackage"; 47 | stackFile = "stack-9.0.yaml"; 48 | ghc-ver = "ghc901"; 49 | }; 50 | }; 51 | module-flags = [ 52 | # N.B.: There are haskell-nix module options. See the haskell-nix docs 53 | # for details. Also, be careful about typos: In many cases you 54 | # will not get errors but the typo'd flag will just not have any 55 | # effect! 56 | # { packages.my-package.flags.my-package-examples-examples = true; } 57 | ]; 58 | default-target = "hackage-8-06"; 59 | do-check-hackage = "hackage.haskell.org"; 60 | do-check-changelog = "changelog.md"; 61 | # local-config-path = ./seaaye-local.nix; 62 | } -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./nix/all.nix).default.shell 2 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiGST.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's RWS / RWST 2 | module Control.Monad.Trans.MultiGST 3 | ( 4 | -- * MultiRWST 5 | MultiGSTT(..) 6 | , MultiGSTTNull 7 | , MultiGST 8 | -- * MonadMulti classes 9 | , ContainsReader 10 | , ContainsState 11 | , ContainsWriter 12 | , MonadMultiReader(..) 13 | , MonadMultiWriter(..) 14 | , MonadMultiGet(..) 15 | , CanReadWrite(..) 16 | -- * run-functions (extracting from RWST) 17 | , runMultiGSTTNil 18 | , runMultiGSTTNil_ 19 | -- * with-functions (extending an RWST) 20 | , withReader 21 | , withReader_ 22 | , withReaders 23 | , withWriter 24 | , withWriterAW 25 | , withWriterWA 26 | , withWriterW 27 | , withState 28 | , withStateAS 29 | , withStateSA 30 | , withStateA 31 | , withStateS 32 | , withState_ 33 | -- * without-functions (reducing an RWST; inverse of with) 34 | , without 35 | -- * other functions 36 | , mapMultiGSTT 37 | , mGetRawR 38 | , mSetRaw 39 | , mGetRaw 40 | ) where 41 | 42 | 43 | 44 | -- just re-export 45 | import Control.Monad.Trans.MultiGST.Lazy 46 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiGST/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE UndecidableSuperClasses #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | -- | Common definitions for MultiGST.Strict and MultiGST.Lazy 9 | module Control.Monad.Trans.MultiGST.Common 10 | ( HListM(..) 11 | , CanReadWrite(..) 12 | , CanReadWriteFlag(..) 13 | , HListMContainsImplication 14 | , HListMContains(..) 15 | , ContainsReader 16 | , ContainsState 17 | , ContainsWriter 18 | , CanWriteConstraint 19 | , AppendM 20 | , HListMReaders 21 | , AppendMReaders 22 | , HListMGettableClass(..) 23 | ) 24 | where 25 | 26 | 27 | 28 | import Data.Kind (Type) 29 | import Data.Semigroup 30 | import qualified Data.HList.HList as HList 31 | 32 | import Control.Monad.Trans.MultiReader.Class 33 | import Control.Monad.Trans.MultiWriter.Class 34 | import Control.Monad.Trans.MultiState.Class 35 | 36 | import GHC.Exts (Constraint) 37 | 38 | 39 | 40 | data CanReadWrite a 41 | = Gettable a 42 | | Settable a 43 | | Tellable a 44 | 45 | data CanReadWriteFlag 46 | = GettableFlag 47 | | SettableFlag 48 | | TellableFlag 49 | 50 | type family HListMContainsImplication (can :: CanReadWriteFlag) t cts :: Constraint where 51 | HListMContainsImplication 'GettableFlag t cts = () 52 | HListMContainsImplication 'TellableFlag t cts = () 53 | HListMContainsImplication 'SettableFlag t cts = HListMContains 'GettableFlag t cts 54 | 55 | class HListMContainsImplication can t cts => HListMContains (can :: CanReadWriteFlag) t cts where 56 | readHListMElem :: HListM cts -> t 57 | writeHListMElem :: CanWriteConstraint can => t -> HListM cts -> HListM cts 58 | 59 | type ContainsReader = HListMContains 'GettableFlag 60 | type ContainsState = HListMContains 'SettableFlag 61 | type ContainsWriter = HListMContains 'TellableFlag 62 | 63 | instance 64 | #if MIN_VERSION_base(4,8,0) 65 | {-# OVERLAPPING #-} 66 | #endif 67 | HListMContains 'GettableFlag x ('Gettable x ': tr) where 68 | readHListMElem (x :+-: _) = x 69 | writeHListMElem = error "writeHListMElem CanRead" 70 | -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled.. 71 | 72 | instance 73 | #if MIN_VERSION_base(4,8,0) 74 | {-# OVERLAPPING #-} 75 | #endif 76 | HListMContains 'GettableFlag x ('Settable x ': tr) where 77 | readHListMElem (x :++: _) = x 78 | writeHListMElem = error "writeHListMElem CanRead" 79 | -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled.. 80 | 81 | instance HListMContains 'GettableFlag x ts => HListMContains 'GettableFlag x (t ': ts) where 82 | readHListMElem (_ :+-: xr) = readHListMElem @'GettableFlag xr 83 | readHListMElem (_ :-+: xr) = readHListMElem @'GettableFlag xr 84 | readHListMElem (_ :++: xr) = readHListMElem @'GettableFlag xr 85 | writeHListMElem = error "writeHListMElem CanRead" 86 | 87 | instance 88 | #if MIN_VERSION_base(4,8,0) 89 | {-# OVERLAPPING #-} 90 | #endif 91 | HListMContains 'TellableFlag x ('Tellable x ': tr) where 92 | readHListMElem (x :-+: _) = x 93 | writeHListMElem x ts = case ts of (_ :-+: tr) -> x :-+: tr 94 | 95 | instance HListMContains 'TellableFlag x ts => HListMContains 'TellableFlag x (t ': ts) where 96 | readHListMElem (_ :+-: xr) = readHListMElem @'TellableFlag xr 97 | readHListMElem (_ :-+: xr) = readHListMElem @'TellableFlag xr 98 | readHListMElem (_ :++: xr) = readHListMElem @'TellableFlag xr 99 | writeHListMElem x (t :+-: tr) = t :+-: writeHListMElem @'TellableFlag x tr 100 | writeHListMElem x (t :-+: tr) = t :-+: writeHListMElem @'TellableFlag x tr 101 | writeHListMElem x (t :++: tr) = t :++: writeHListMElem @'TellableFlag x tr 102 | 103 | instance 104 | #if MIN_VERSION_base(4,8,0) 105 | {-# OVERLAPPING #-} 106 | #endif 107 | HListMContains 'GettableFlag x ('Settable x ': tr) 108 | => HListMContains 'SettableFlag x ('Settable x ': tr) where 109 | readHListMElem (x :++: _) = x 110 | writeHListMElem x ts = case ts of (_ :++: tr) -> x :++: tr 111 | 112 | instance HListMContains 'SettableFlag x ts => HListMContains 'SettableFlag x (t ': ts) where 113 | readHListMElem (_ :+-: xr) = readHListMElem @'SettableFlag xr 114 | readHListMElem (_ :-+: xr) = readHListMElem @'SettableFlag xr 115 | readHListMElem (_ :++: xr) = readHListMElem @'SettableFlag xr 116 | writeHListMElem x (t :+-: tr) = t :+-: writeHListMElem @'SettableFlag x tr 117 | writeHListMElem x (t :-+: tr) = t :-+: writeHListMElem @'SettableFlag x tr 118 | writeHListMElem x (t :++: tr) = t :++: writeHListMElem @'SettableFlag x tr 119 | 120 | 121 | type family CanWriteConstraint (f :: CanReadWriteFlag) :: Constraint where 122 | CanWriteConstraint 'TellableFlag = () 123 | CanWriteConstraint 'SettableFlag = () 124 | 125 | data HListM :: [CanReadWrite Type] -> Type where 126 | HNilM :: HListM '[] 127 | (:+-:) :: x -> HListM xr -> HListM ('Gettable x ': xr) 128 | (:++:) :: x -> HListM xr -> HListM ('Settable x ': xr) 129 | (:-+:) :: x -> HListM xr -> HListM ('Tellable x ': xr) 130 | 131 | instance Semigroup (HListM '[]) where 132 | _ <> _ = HNilM 133 | 134 | instance Monoid (HListM '[]) where 135 | mempty = HNilM 136 | mappend = (<>) 137 | 138 | instance Eq (HListM '[]) where 139 | HNilM == HNilM = True 140 | HNilM /= HNilM = False 141 | 142 | instance (Eq x, Eq (HListM xs)) 143 | => Eq (HListM ('Gettable x ': xs)) 144 | where 145 | x1 :+-: xr1 == x2 :+-: xr2 = x1==x2 && xr1==xr2 146 | x1 :+-: xr1 /= x2 :+-: xr2 = x1/=x2 || xr1/=xr2 147 | instance (Eq x, Eq (HListM xs)) 148 | => Eq (HListM ('Tellable x ': xs)) 149 | where 150 | x1 :-+: xr1 == x2 :-+: xr2 = x1==x2 && xr1==xr2 151 | x1 :-+: xr1 /= x2 :-+: xr2 = x1/=x2 || xr1/=xr2 152 | instance (Eq x, Eq (HListM xs)) 153 | => Eq (HListM ('Settable x ': xs)) 154 | where 155 | x1 :++: xr1 == x2 :++: xr2 = x1==x2 && xr1==xr2 156 | x1 :++: xr1 /= x2 :++: xr2 = x1/=x2 || xr1/=xr2 157 | 158 | type family AppendM (l1 :: [CanReadWrite Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where 159 | AppendM '[] l2 = l2 160 | AppendM (car1 ': cdr2) l2 = car1 ': AppendM cdr2 l2 161 | 162 | type family HListMReaders (l :: [Type]) :: [CanReadWrite Type] where 163 | HListMReaders '[] = '[] 164 | HListMReaders (t ': tr) = 'Gettable t ': HListMReaders tr 165 | 166 | type family AppendMReaders (l1 :: [Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where 167 | AppendMReaders '[] l2 = l2 168 | AppendMReaders (t ': tr) l2 = 'Gettable t ': AppendMReaders tr l2 169 | 170 | class HListMGettableClass ts where 171 | type HListMGettableOnly ts :: [Type] 172 | hListMGettableOnly :: HListM ts -> HList.HList (HListMGettableOnly ts) 173 | 174 | instance HListMGettableClass '[] where 175 | type HListMGettableOnly '[] = '[] 176 | hListMGettableOnly HNilM = HList.HNil 177 | 178 | instance HListMGettableClass tr => HListMGettableClass ('Gettable t ': tr) where 179 | type HListMGettableOnly ('Gettable t ': tr) = (t ': HListMGettableOnly tr) 180 | hListMGettableOnly (t :+-: tr) = t HList.:+: hListMGettableOnly tr 181 | instance HListMGettableClass tr => HListMGettableClass ('Settable t ': tr) where 182 | type HListMGettableOnly ('Settable t ': tr) = HListMGettableOnly tr 183 | hListMGettableOnly (_ :++: tr) = hListMGettableOnly tr 184 | instance HListMGettableClass tr => HListMGettableClass ('Tellable t ': tr) where 185 | type HListMGettableOnly ('Tellable t ': tr) = HListMGettableOnly tr 186 | hListMGettableOnly (_ :-+: tr) = hListMGettableOnly tr 187 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiGST/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UndecidableSuperClasses #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | -- | Alternative multi-valued version of mtl's RWS / RWST. In contrast to 9 | -- @'MultiRWS'(T)@ this version only takes a single list of types as 10 | -- parameter, but with additional encoding of the allowed access for each 11 | -- element. This supports the @'MonadMultiGet'@ notion more succinctly, i.e. 12 | -- to pass a "state" element to a function that only requires/expects read/get 13 | -- access. This is not possible with 'MultiRWS'. 14 | module Control.Monad.Trans.MultiGST.Lazy 15 | ( MultiGSTT(..) 16 | , MultiGSTTNull 17 | , MultiGST 18 | -- * MonadMulti classes 19 | , ContainsReader 20 | , ContainsState 21 | , ContainsWriter 22 | , MonadMultiReader(..) 23 | , MonadMultiWriter(..) 24 | , MonadMultiGet(..) 25 | , MonadMultiState(..) 26 | , CanReadWrite(..) 27 | -- * run-functions 28 | , runMultiGSTTNil 29 | , runMultiGSTTNil_ 30 | -- * with-functions 31 | , withReader 32 | , withReader_ 33 | , withReaders 34 | , withWriter 35 | , withWriterAW 36 | , withWriterWA 37 | , withWriterW 38 | , withState 39 | , withStateAS 40 | , withStateSA 41 | , withStateA 42 | , withStateS 43 | , withState_ 44 | -- * without-functions 45 | , without 46 | -- * other functions 47 | , mGetRaw 48 | , mSetRaw 49 | , mGetRawR 50 | , mapMultiGSTT 51 | ) 52 | where 53 | 54 | 55 | 56 | import Control.Monad.State.Lazy ( StateT(..) 57 | , MonadState(..) 58 | , execStateT 59 | , evalStateT 60 | , mapStateT ) 61 | 62 | import Data.Functor.Identity ( Identity ) 63 | 64 | import Control.Monad.Trans.Class ( MonadTrans 65 | , lift 66 | ) 67 | import Control.Monad ( MonadPlus(..) 68 | , liftM 69 | , ap 70 | , void 71 | ) 72 | import Control.Applicative ( Applicative(..) 73 | , Alternative(..) 74 | ) 75 | import Control.Monad.Fix ( MonadFix(..) ) 76 | import Control.Monad.IO.Class ( MonadIO(..) ) 77 | 78 | import Data.Monoid ( Monoid 79 | , (<>) 80 | ) 81 | 82 | 83 | import GHC.Exts (Constraint) 84 | 85 | import Control.Monad.Trans.MultiReader.Class 86 | import Control.Monad.Trans.MultiWriter.Class 87 | import Control.Monad.Trans.MultiState.Class 88 | 89 | import qualified Data.HList.HList as HList 90 | 91 | import Control.Monad.Trans.MultiGST.Common 92 | 93 | 94 | 95 | newtype MultiGSTT ts m a = MultiGSTT { 96 | runMultiGSTTRaw :: StateT (HListM ts) m a 97 | } 98 | deriving(Functor, Applicative, Monad, MonadTrans, MonadIO, Alternative, MonadPlus) 99 | 100 | type MultiGSTTNull = MultiGSTT '[] 101 | 102 | type MultiGST r = MultiGSTT r Identity 103 | 104 | 105 | instance 106 | #if MIN_VERSION_base(4,8,0) 107 | {-# OVERLAPPING #-} 108 | #endif 109 | (Monad m, HListMContains 'GettableFlag a cts) 110 | => MonadMultiGet a (MultiGSTT cts m) where 111 | mGet = MultiGSTT $ liftM (\ts -> readHListMElem @'GettableFlag ts) get 112 | 113 | instance 114 | #if MIN_VERSION_base(4,8,0) 115 | {-# OVERLAPPING #-} 116 | #endif 117 | (Monad m, HListMContains 'SettableFlag a cts) 118 | => MonadMultiState a (MultiGSTT cts m) where 119 | mSet x = MultiGSTT $ do 120 | ts <- get 121 | put $ writeHListMElem @'SettableFlag x ts 122 | 123 | instance 124 | #if MIN_VERSION_base(4,8,0) 125 | {-# OVERLAPPING #-} 126 | #endif 127 | ( Monad m 128 | , Monoid a 129 | , HListMContains 'TellableFlag a cts 130 | ) => MonadMultiWriter a (MultiGSTT cts m) where 131 | mTell x = MultiGSTT $ do 132 | ts <- get 133 | let x' = readHListMElem @'TellableFlag ts 134 | put $ writeHListMElem @'TellableFlag (x' <> x) ts 135 | 136 | runMultiGSTTNil :: Monad m => MultiGSTT '[] m a -> m a 137 | runMultiGSTTNil_ :: Monad m => MultiGSTT '[] m a -> m () 138 | 139 | runMultiGSTTNil k = evalStateT (runMultiGSTTRaw k) (HNilM) 140 | runMultiGSTTNil_ k = liftM (const ()) (evalStateT (runMultiGSTTRaw k) (HNilM)) 141 | 142 | withReader :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m a 143 | withReader x k = MultiGSTT $ do 144 | tr <- get 145 | ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) 146 | put $ case ts' of _ :+-: tr' -> tr' 147 | return a 148 | 149 | withReader_ :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m () 150 | withReader_ x k = MultiGSTT $ do 151 | tr <- get 152 | ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) 153 | put $ case ts' of _ :+-: tr' -> tr' 154 | 155 | withReaders :: Monad m => HList.HList rs -> MultiGSTT (AppendM (HListMReaders rs) ts) m a -> MultiGSTT ts m a 156 | withReaders HList.HNil = id 157 | withReaders (t HList.:+: ts) = withReaders ts . withReader t 158 | 159 | withWriter :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) 160 | withWriterAW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) 161 | withWriterWA :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (t, a) 162 | withWriterW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m t 163 | withWriter = withWriterAW 164 | withWriterAW k = MultiGSTT $ do 165 | tr <- get 166 | ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) 167 | case ts' of 168 | t :-+: tr' -> do 169 | put tr' 170 | return (a, t) 171 | withWriterWA k = MultiGSTT $ do 172 | tr <- get 173 | ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) 174 | case ts' of 175 | t :-+: tr' -> do 176 | put tr' 177 | return (t, a) 178 | withWriterW k = MultiGSTT $ do 179 | tr <- get 180 | ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) 181 | case ts' of 182 | t :-+: tr' -> do 183 | put tr' 184 | return t 185 | 186 | withState :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) 187 | withStateAS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) 188 | withStateSA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (t, a) 189 | withStateA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m a 190 | withStateS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m t 191 | withState_ :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m () 192 | withState = withStateAS 193 | withStateAS t k = MultiGSTT $ do 194 | tr <- get 195 | ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 196 | case ts' of 197 | t' :++: tr' -> do 198 | put tr' 199 | return (a, t') 200 | withStateSA t k = MultiGSTT $ do 201 | tr <- get 202 | ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 203 | case ts' of 204 | t' :++: tr' -> do 205 | put tr' 206 | return (t', a) 207 | withStateA t k = MultiGSTT $ do 208 | tr <- get 209 | ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 210 | case ts' of 211 | _ :++: tr' -> do 212 | put tr' 213 | return a 214 | withStateS t k = MultiGSTT $ do 215 | tr <- get 216 | ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 217 | case ts' of 218 | t' :++: tr' -> do 219 | put tr' 220 | return t' 221 | withState_ t k = MultiGSTT $ do 222 | tr <- get 223 | ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 224 | case ts' of 225 | _ :++: tr' -> do 226 | put tr' 227 | 228 | without :: Monad m => MultiGSTT tr m a -> MultiGSTT (ct ': tr) m a 229 | without k = MultiGSTT $ do 230 | ts <- get 231 | case ts of 232 | (t :+-: tr) -> do 233 | ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr 234 | put (t :+-: tr') 235 | return a 236 | (t :-+: tr) -> do 237 | ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr 238 | put (t :-+: tr') 239 | return a 240 | (t :++: tr) -> do 241 | ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr 242 | put (t :++: tr') 243 | return a 244 | 245 | mGetRaw :: Monad m => MultiGSTT ts m (HListM ts) 246 | mGetRaw = MultiGSTT get 247 | 248 | mGetRawR :: (Monad m, HListMGettableClass ts) => MultiGSTT ts m (HList.HList (HListMGettableOnly ts)) 249 | mGetRawR = MultiGSTT $ liftM hListMGettableOnly get 250 | 251 | mSetRaw :: Monad m => HListM ts -> MultiGSTT ts m () 252 | mSetRaw = MultiGSTT . put 253 | 254 | mapMultiGSTT 255 | :: (ts ~ HListM cts) 256 | => (m (a, ts) -> m' (a', ts)) 257 | -> MultiGSTT cts m a 258 | -> MultiGSTT cts m' a' 259 | mapMultiGSTT f = MultiGSTT . mapStateT f . runMultiGSTTRaw 260 | 261 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiGST/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UndecidableSuperClasses #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | -- | Alternative multi-valued version of mtl's RWS / RWST. In contrast to 9 | -- @'MultiRWS'(T)@ this version only takes a single list of types as 10 | -- parameter, but with additional encoding of the allowed access for each 11 | -- element. This supports the @'MonadMultiGet'@ notion more succinctly, i.e. 12 | -- to pass a "state" element to a function that only requires/expects read/get 13 | -- access. This is not possible with 'MultiRWS'. 14 | module Control.Monad.Trans.MultiGST.Strict 15 | ( MultiGSTT(..) 16 | , MultiGSTTNull 17 | , MultiGST 18 | -- * MonadMulti classes 19 | , ContainsReader 20 | , ContainsState 21 | , ContainsWriter 22 | , MonadMultiReader(..) 23 | , MonadMultiWriter(..) 24 | , MonadMultiGet(..) 25 | , CanReadWrite(..) 26 | -- * run-functions 27 | , runMultiGSTTNil 28 | , runMultiGSTTNil_ 29 | -- * with-functions 30 | , withReader 31 | , withReader_ 32 | , withWriter 33 | , withWriterAW 34 | , withWriterWA 35 | , withWriterW 36 | , withState 37 | , withStateAS 38 | , withStateSA 39 | , withStateA 40 | , withStateS 41 | , withState_ 42 | -- * without-functions 43 | , without 44 | -- * other functions 45 | , mGetRaw 46 | , mSetRaw 47 | , mapMultiGSTT 48 | ) 49 | where 50 | 51 | 52 | 53 | import Control.Monad.State.Strict ( StateT(..) 54 | , MonadState(..) 55 | , execStateT 56 | , evalStateT 57 | , mapStateT ) 58 | 59 | import Data.Functor.Identity ( Identity ) 60 | 61 | import Control.Monad.Trans.Class ( MonadTrans 62 | , lift 63 | ) 64 | import Control.Monad ( MonadPlus(..) 65 | , liftM 66 | , ap 67 | , void ) 68 | 69 | import Data.Monoid ( Monoid 70 | , (<>) 71 | ) 72 | 73 | import GHC.Exts (Constraint) 74 | 75 | import Control.Monad.Trans.MultiReader.Class 76 | import Control.Monad.Trans.MultiWriter.Class 77 | import Control.Monad.Trans.MultiState.Class 78 | 79 | import Control.Monad.Trans.MultiGST.Common 80 | 81 | 82 | 83 | newtype MultiGSTT ts m a = MultiGSTT { 84 | runMultiGSTTRaw :: StateT (HListM ts) m a 85 | } 86 | deriving(Functor, Applicative, Monad, MonadTrans) 87 | 88 | type MultiGSTTNull = MultiGSTT '[] 89 | 90 | type MultiGST r = MultiGSTT r Identity 91 | 92 | 93 | instance 94 | #if MIN_VERSION_base(4,8,0) 95 | {-# OVERLAPPING #-} 96 | #endif 97 | (Monad m, HListMContains 'GettableFlag a cts) 98 | => MonadMultiGet a (MultiGSTT cts m) where 99 | mGet = MultiGSTT $ liftM (\ts -> readHListMElem @'GettableFlag ts) get 100 | 101 | instance 102 | #if MIN_VERSION_base(4,8,0) 103 | {-# OVERLAPPING #-} 104 | #endif 105 | (Monad m, HListMContains 'SettableFlag a cts) 106 | => MonadMultiState a (MultiGSTT cts m) where 107 | mSet x = MultiGSTT $ do 108 | ts <- get 109 | put $ writeHListMElem @'SettableFlag x ts 110 | 111 | instance 112 | #if MIN_VERSION_base(4,8,0) 113 | {-# OVERLAPPING #-} 114 | #endif 115 | ( Monad m 116 | , Monoid a 117 | , HListMContains 'TellableFlag a cts 118 | ) => MonadMultiWriter a (MultiGSTT cts m) where 119 | mTell x = MultiGSTT $ do 120 | ts <- get 121 | let x' = readHListMElem @'TellableFlag ts 122 | put $ writeHListMElem @'TellableFlag (x' <> x) ts 123 | 124 | runMultiGSTTNil :: Monad m => MultiGSTT '[] m a -> m a 125 | runMultiGSTTNil_ :: Monad m => MultiGSTT '[] m a -> m () 126 | 127 | runMultiGSTTNil k = evalStateT (runMultiGSTTRaw k) (HNilM) 128 | runMultiGSTTNil_ k = liftM (const ()) (evalStateT (runMultiGSTTRaw k) (HNilM)) 129 | 130 | withReader :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m a 131 | withReader x k = MultiGSTT $ do 132 | tr <- get 133 | (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) 134 | put $ case ts' of _ :+-: tr' -> tr' 135 | return a 136 | 137 | withReader_ :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m () 138 | withReader_ x k = MultiGSTT $ do 139 | tr <- get 140 | (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr) 141 | put $ case ts' of _ :+-: tr' -> tr' 142 | 143 | withWriter :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) 144 | withWriterAW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t) 145 | withWriterWA :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (t, a) 146 | withWriterW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m t 147 | withWriter = withWriterAW 148 | withWriterAW k = MultiGSTT $ do 149 | tr <- get 150 | (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) 151 | case ts' of 152 | t :-+: tr' -> do 153 | put tr' 154 | return (a, t) 155 | withWriterWA k = MultiGSTT $ do 156 | tr <- get 157 | (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) 158 | case ts' of 159 | t :-+: tr' -> do 160 | put tr' 161 | return (t, a) 162 | withWriterW k = MultiGSTT $ do 163 | tr <- get 164 | (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr) 165 | case ts' of 166 | t :-+: tr' -> do 167 | put tr' 168 | return t 169 | 170 | withState :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) 171 | withStateAS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t) 172 | withStateSA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (t, a) 173 | withStateA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m a 174 | withStateS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m t 175 | withState_ :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m () 176 | withState = withStateAS 177 | withStateAS t k = MultiGSTT $ do 178 | tr <- get 179 | (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 180 | case ts' of 181 | t' :++: tr' -> do 182 | put tr' 183 | return (a, t') 184 | withStateSA t k = MultiGSTT $ do 185 | tr <- get 186 | (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 187 | case ts' of 188 | t' :++: tr' -> do 189 | put tr' 190 | return (t', a) 191 | withStateA t k = MultiGSTT $ do 192 | tr <- get 193 | (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 194 | case ts' of 195 | _ :++: tr' -> do 196 | put tr' 197 | return a 198 | withStateS t k = MultiGSTT $ do 199 | tr <- get 200 | (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 201 | case ts' of 202 | t' :++: tr' -> do 203 | put tr' 204 | return t' 205 | withState_ t k = MultiGSTT $ do 206 | tr <- get 207 | (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr) 208 | case ts' of 209 | _ :++: tr' -> do 210 | put tr' 211 | 212 | without :: Monad m => MultiGSTT tr m a -> MultiGSTT (ct ': tr) m a 213 | without k = MultiGSTT $ do 214 | ts <- get 215 | case ts of 216 | (t :+-: tr) -> do 217 | (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr 218 | put (t :+-: tr') 219 | return a 220 | (t :-+: tr) -> do 221 | (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr 222 | put (t :-+: tr') 223 | return a 224 | (t :++: tr) -> do 225 | (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr 226 | put (t :++: tr') 227 | return a 228 | 229 | mGetRaw :: Monad m => MultiGSTT ts m (HListM ts) 230 | mGetRaw = MultiGSTT get 231 | 232 | mSetRaw :: Monad m => HListM ts -> MultiGSTT ts m () 233 | mSetRaw = MultiGSTT . put 234 | 235 | mapMultiGSTT 236 | :: (ts ~ HListM cts) 237 | => (m (a, ts) -> m' (a', ts)) 238 | -> MultiGSTT cts m a 239 | -> MultiGSTT cts m' a' 240 | mapMultiGSTT f = MultiGSTT . mapStateT f . runMultiGSTTRaw 241 | 242 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiGet/Class.hs: -------------------------------------------------------------------------------- 1 | -- | The MonadMultiReader type-class 2 | module Control.Monad.Trans.MultiGet.Class 3 | ( 4 | -- * MonadMultiReader class 5 | MonadMultiGet(..) 6 | ) 7 | where 8 | 9 | 10 | 11 | import Control.Monad.Trans.Class ( MonadTrans 12 | , lift ) 13 | 14 | 15 | 16 | -- | In contrast to MonadMultiReader, MonadMultiGet is defined for State too, 17 | -- so it corresponds to read-access of any kind. 18 | -- 19 | -- Note however that for MultiRWS, only the values from the @state@ part can 20 | -- be accessed via @MonadMultiGet@, due to limitations of the design of 21 | -- @MultiRWS@ and of the type system. This is issue is resolved in the 22 | -- @MultiGST@ type. 23 | class (Monad m) => MonadMultiGet a m where 24 | mGet :: m a -- ^ Access to a specific type in the environment. 25 | 26 | instance (MonadTrans t, Monad (t m), MonadMultiGet a m) 27 | => MonadMultiGet a (t m) where 28 | mGet = lift $ mGet 29 | 30 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiRWS.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's RWS / RWST 2 | module Control.Monad.Trans.MultiRWS 3 | ( 4 | -- * MultiRWST 5 | MultiRWST(..) 6 | , MultiRWSTNull 7 | , MultiRWS 8 | -- * MonadMulti classes 9 | , MonadMultiReader(..) 10 | , MonadMultiWriter(..) 11 | , MonadMultiGet(..) 12 | , MonadMultiState(..) 13 | -- * run-functions (extracting from RWST) 14 | , runMultiRWST 15 | , runMultiRWSTASW 16 | , runMultiRWSTW 17 | , runMultiRWSTAW 18 | , runMultiRWSTSW 19 | , runMultiRWSTNil 20 | , runMultiRWSTNil_ 21 | -- * with-functions (extending an RWST) 22 | , withMultiReader 23 | , withMultiReader_ 24 | , withMultiReaders 25 | , withMultiReaders_ 26 | , withMultiWriter 27 | , withMultiWriterAW 28 | , withMultiWriterWA 29 | , withMultiWriterW 30 | , withMultiWriters 31 | , withMultiWritersAW 32 | , withMultiWritersWA 33 | , withMultiWritersW 34 | , withMultiState 35 | , withMultiStateAS 36 | , withMultiStateSA 37 | , withMultiStateA 38 | , withMultiStateS 39 | , withMultiState_ 40 | , withMultiStates 41 | , withMultiStatesAS 42 | , withMultiStatesSA 43 | , withMultiStatesA 44 | , withMultiStatesS 45 | , withMultiStates_ 46 | -- * without-functions (reducing an RWST; inverse of with) 47 | , withoutMultiReader 48 | , withoutMultiState 49 | -- * inflate-functions (run simple transformer in MultiRWST) 50 | , inflateReader 51 | , inflateMultiReader 52 | , inflateWriter 53 | , inflateMultiWriter 54 | , inflateState 55 | , inflateMultiState 56 | -- * other functions 57 | , mapMultiRWST 58 | , mGetRawR 59 | , mGetRawW 60 | , mGetRawS 61 | , mPutRawR 62 | , mPutRawW 63 | , mPutRawS 64 | ) where 65 | 66 | 67 | 68 | -- just re-export 69 | import Control.Monad.Trans.MultiRWS.Lazy 70 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiRWS/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | The multi-valued version of mtl's RWS / RWST 7 | module Control.Monad.Trans.MultiRWS.Lazy 8 | ( 9 | -- * MultiRWST 10 | MultiRWST(..) 11 | , MultiRWSTNull 12 | , MultiRWS 13 | -- * MonadMulti classes 14 | , MonadMultiReader(..) 15 | , MonadMultiWriter(..) 16 | , MonadMultiGet(..) 17 | , MonadMultiState(..) 18 | -- * run-functions (extracting from RWST) 19 | , runMultiRWST 20 | , runMultiRWSTASW 21 | , runMultiRWSTW 22 | , runMultiRWSTAW 23 | , runMultiRWSTSW 24 | , runMultiRWSTNil 25 | , runMultiRWSTNil_ 26 | -- * with-functions (extending an RWST) 27 | , withMultiReader 28 | , withMultiReader_ 29 | , withMultiReaders 30 | , withMultiReaders_ 31 | , withMultiWriter 32 | , withMultiWriterAW 33 | , withMultiWriterWA 34 | , withMultiWriterW 35 | , withMultiWriters 36 | , withMultiWritersAW 37 | , withMultiWritersWA 38 | , withMultiWritersW 39 | , withMultiState 40 | , withMultiStateAS 41 | , withMultiStateSA 42 | , withMultiStateA 43 | , withMultiStateS 44 | , withMultiState_ 45 | , withMultiStates 46 | , withMultiStatesAS 47 | , withMultiStatesSA 48 | , withMultiStatesA 49 | , withMultiStatesS 50 | , withMultiStates_ 51 | -- * without-functions (reducing an RWST; inverse of with) 52 | , withoutMultiReader 53 | , withoutMultiState 54 | -- * inflate-functions (run simple transformer in MultiRWST) 55 | , inflateReader 56 | , inflateMultiReader 57 | , inflateWriter 58 | , inflateMultiWriter 59 | , inflateState 60 | , inflateMultiState 61 | -- * other functions 62 | , mapMultiRWST 63 | , mGetRawR 64 | , mGetRawW 65 | , mGetRawS 66 | , mPutRawR 67 | , mPutRawW 68 | , mPutRawS 69 | ) 70 | where 71 | 72 | 73 | 74 | import Data.HList.HList 75 | import Data.HList.ContainsType 76 | 77 | import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) 78 | import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) 79 | import Control.Monad.Trans.MultiState.Class 80 | import Control.Monad.Trans.MultiReader.Lazy ( MultiReaderT(..) 81 | , runMultiReaderT ) 82 | import Control.Monad.Trans.MultiWriter.Lazy ( MultiWriterT(..) 83 | , runMultiWriterT ) 84 | import Control.Monad.Trans.MultiState.Lazy ( MultiStateT(..) 85 | , runMultiStateT ) 86 | 87 | import Control.Monad.State.Lazy ( StateT(..) 88 | , MonadState(..) 89 | , execStateT 90 | , evalStateT 91 | , mapStateT ) 92 | import Control.Monad.Reader ( ReaderT(..) ) 93 | import Control.Monad.Writer.Lazy ( WriterT(..) ) 94 | import Control.Monad.Trans.Class ( MonadTrans 95 | , lift ) 96 | 97 | import Data.Functor.Identity ( Identity ) 98 | 99 | import Control.Applicative ( Applicative(..) 100 | , Alternative(..) 101 | ) 102 | import Control.Monad ( MonadPlus(..) 103 | , liftM 104 | , ap 105 | , void ) 106 | import Control.Monad.Base ( MonadBase(..) 107 | , liftBaseDefault 108 | ) 109 | import Control.Monad.Trans.Control ( MonadTransControl(..) 110 | , MonadBaseControl(..) 111 | , ComposeSt 112 | , defaultLiftBaseWith 113 | , defaultRestoreM 114 | ) 115 | import Control.Monad.Fix ( MonadFix(..) ) 116 | import Control.Monad.IO.Class ( MonadIO(..) ) 117 | 118 | import Data.Monoid 119 | 120 | 121 | 122 | newtype MultiRWST r w s m a = MultiRWST { 123 | runMultiRWSTRaw :: StateT (HList r, HList w, HList s) m a 124 | } 125 | 126 | type MultiRWSTNull = MultiRWST '[] '[] '[] 127 | 128 | type MultiRWS r w s = MultiRWST r w s Identity 129 | 130 | instance (Functor f) => Functor (MultiRWST r w s f) where 131 | fmap f = MultiRWST . fmap f . runMultiRWSTRaw 132 | 133 | instance (Applicative m, Monad m) => Applicative (MultiRWST r w s m) where 134 | pure = MultiRWST . pure 135 | (<*>) = ap 136 | 137 | instance (Monad m) => Monad (MultiRWST r w s m) where 138 | return = pure 139 | k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f 140 | 141 | instance MonadTrans (MultiRWST r w s) where 142 | lift = MultiRWST . lift 143 | 144 | instance 145 | #if MIN_VERSION_base(4,8,0) 146 | {-# OVERLAPPING #-} 147 | #endif 148 | (Monad m, ContainsType a r) 149 | => MonadMultiReader a (MultiRWST r w s m) where 150 | mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get 151 | 152 | instance 153 | #if MIN_VERSION_base(4,8,0) 154 | {-# OVERLAPPING #-} 155 | #endif 156 | (Monad m, ContainsType a w, Monoid a) 157 | => MonadMultiWriter a (MultiRWST r w s m) where 158 | mTell v = MultiRWST $ do 159 | ~(r,w,s) <- get 160 | put $ (r, setHListElem (getHListElem w `mappend` v) w, s) 161 | 162 | instance 163 | #if MIN_VERSION_base(4,8,0) 164 | {-# OVERLAPPING #-} 165 | #endif 166 | (Monad m, ContainsType a s) 167 | => MonadMultiGet a (MultiRWST r w s m) where 168 | mGet = MultiRWST $ do 169 | ~(_,_,s) <- get 170 | return $ getHListElem s 171 | 172 | instance 173 | #if MIN_VERSION_base(4,8,0) 174 | {-# OVERLAPPING #-} 175 | #endif 176 | (Monad m, ContainsType a s) 177 | => MonadMultiState a (MultiRWST r w s m) where 178 | mSet v = MultiRWST $ do 179 | ~(r,w,s) <- get 180 | put (r, w, setHListElem v s) 181 | 182 | instance MonadFix m => MonadFix (MultiRWST r w s m) where 183 | mfix f = MultiRWST $ mfix (runMultiRWSTRaw . f) 184 | 185 | -- methods 186 | 187 | runMultiRWST :: ( Monad m 188 | , Monoid (HList w) 189 | ) 190 | => HList r 191 | -> HList s 192 | -> MultiRWST r w s m a 193 | -> m (a, HList s, HList w) 194 | runMultiRWSTASW :: ( Monad m 195 | , Monoid (HList w) 196 | ) 197 | => HList r 198 | -> HList s 199 | -> MultiRWST r w s m a 200 | -> m (a, HList s, HList w) 201 | runMultiRWSTW :: ( Monad m 202 | , Monoid (HList w) 203 | ) 204 | => HList r 205 | -> HList s 206 | -> MultiRWST r w s m a 207 | -> m (HList w) 208 | runMultiRWSTAW :: ( Monad m 209 | , Monoid (HList w) 210 | ) 211 | => HList r 212 | -> HList s 213 | -> MultiRWST r w s m a 214 | -> m (a, HList w) 215 | runMultiRWSTSW :: ( Monad m 216 | , Monoid (HList w) 217 | ) 218 | => HList r 219 | -> HList s 220 | -> MultiRWST r w s m a 221 | -> m (HList s, HList w) 222 | 223 | runMultiRWSTNil :: ( Monad m ) 224 | => MultiRWST '[] '[] '[] m a 225 | -> m a 226 | runMultiRWSTNil_ :: ( Monad m, Functor m ) 227 | => MultiRWST '[] '[] '[] m a 228 | -> m () 229 | runMultiRWST = runMultiRWSTASW 230 | runMultiRWSTASW r s k = do 231 | ~(x, ~(_, w, s')) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) 232 | return $ (x, s', w) 233 | runMultiRWSTW r s k = do 234 | ~(_, w, _) <- execStateT (runMultiRWSTRaw k) (r, mempty, s) 235 | return $ w 236 | runMultiRWSTAW r s k = do 237 | ~(x, ~(_, w, _)) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) 238 | return $ (x, w) 239 | runMultiRWSTSW r s k = do 240 | ~(_, w, s') <- execStateT (runMultiRWSTRaw k) (r, mempty, s) 241 | return $ (s', w) 242 | runMultiRWSTNil k = evalStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) 243 | runMultiRWSTNil_ k = void $ runStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) 244 | 245 | withMultiReader :: Monad m => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m a 246 | withMultiReader_ :: (Functor m, Monad m) => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m () 247 | withMultiReaders :: Monad m => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m a 248 | withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m () 249 | withMultiReader x k = MultiRWST $ do 250 | (r, w, s) <- get 251 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (x :+: r, w, s) 252 | put (r, w', s') 253 | return a 254 | withMultiReader_ x k = MultiRWST $ do 255 | (r, w, s) <- get 256 | ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (x :+: r, w, s) 257 | put (r, w', s') 258 | withMultiReaders HNil = id 259 | withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x 260 | withMultiReaders_ HNil = void 261 | withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader x 262 | 263 | withMultiWriter :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) 264 | withMultiWriterAW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) 265 | withMultiWriterWA :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (w, a) 266 | withMultiWriterW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m w 267 | withMultiWriters :: forall r w1 w2 s m a 268 | . (Monoid (HList w1), Monad m, HInit w1) 269 | => MultiRWST r (Append w1 w2) s m a 270 | -> MultiRWST r w2 s m (a, HList w1) 271 | withMultiWritersAW :: forall r w1 w2 s m a 272 | . (Monoid (HList w1), Monad m, HInit w1) 273 | => MultiRWST r (Append w1 w2) s m a 274 | -> MultiRWST r w2 s m (a, HList w1) 275 | withMultiWritersWA :: forall r w1 w2 s m a 276 | . (Monoid (HList w1), Monad m, HInit w1) 277 | => MultiRWST r (Append w1 w2) s m a 278 | -> MultiRWST r w2 s m (HList w1, a) 279 | withMultiWritersW :: forall r w1 w2 s m a 280 | . (Monoid (HList w1), Monad m, HInit w1) 281 | => MultiRWST r (Append w1 w2) s m a 282 | -> MultiRWST r w2 s m (HList w1) 283 | withMultiWriter = withMultiWriterAW 284 | withMultiWriterAW k = MultiRWST $ do 285 | (r, w, s) <- get 286 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) 287 | case w' of 288 | x' :+: wr' -> do 289 | put (r, wr', s') 290 | return (a, x') 291 | withMultiWriterWA k = MultiRWST $ do 292 | (r, w, s) <- get 293 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) 294 | case w' of 295 | x' :+: wr' -> do 296 | put (r, wr', s') 297 | return (x', a) 298 | withMultiWriterW k = MultiRWST $ do 299 | (r, w, s) <- get 300 | ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) 301 | case w' of 302 | x' :+: wr' -> do 303 | put (r, wr', s') 304 | return x' 305 | withMultiWriters = withMultiWritersAW 306 | withMultiWritersAW k = MultiRWST $ do 307 | (r, w, s) <- get 308 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) 309 | let (o, wr') = hSplit w' 310 | put (r, wr', s') 311 | return (a, o) 312 | withMultiWritersWA k = MultiRWST $ do 313 | (r, w, s) <- get 314 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) 315 | let (o, wr') = hSplit w' 316 | put (r, wr', s') 317 | return (o, a) 318 | withMultiWritersW k = MultiRWST $ do 319 | (r, w, s) <- get 320 | ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) 321 | let (o, wr') = hSplit w' 322 | put (r, wr', s') 323 | return o 324 | 325 | withMultiState :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) 326 | withMultiStateAS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) 327 | withMultiStateSA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (s, a) 328 | withMultiStateA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m a 329 | withMultiStateS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m s 330 | withMultiState_ :: (Functor m, Monad m) => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m () 331 | withMultiStates :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) 332 | withMultiStatesAS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) 333 | withMultiStatesSA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1, a) 334 | withMultiStatesA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m a 335 | withMultiStatesS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1) 336 | withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m () 337 | withMultiState = withMultiStateAS 338 | withMultiStateAS x k = MultiRWST $ do 339 | ~(r, w, s) <- get 340 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 341 | case s' of 342 | x' :+: sr' -> do 343 | put (r, w', sr') 344 | return (a, x') 345 | withMultiStateSA x k = MultiRWST $ do 346 | ~(r, w, s) <- get 347 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 348 | case s' of 349 | x' :+: sr' -> do 350 | put (r, w', sr') 351 | return (x', a) 352 | withMultiStateA x k = MultiRWST $ do 353 | ~(r, w, s) <- get 354 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 355 | case s' of 356 | _ :+: sr' -> do 357 | put (r, w', sr') 358 | return a 359 | withMultiStateS x k = MultiRWST $ do 360 | ~(r, w, s) <- get 361 | ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 362 | case s' of 363 | x' :+: sr' -> do 364 | put (r, w', sr') 365 | return x' 366 | withMultiState_ x k = MultiRWST $ do 367 | ~(r, w, s) <- get 368 | ~(_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 369 | case s' of _ :+: sr' -> put (r, w', sr') 370 | withMultiStates = withMultiStatesAS 371 | withMultiStatesAS HNil k = do a <- k; return (a, HNil) 372 | withMultiStatesAS (x :+: xs) k = do 373 | ~(~(a, x'), xs') <- withMultiStates xs $ withMultiState x k 374 | return (a, x' :+: xs') 375 | withMultiStatesSA HNil k = do a <- k; return (HNil, a) 376 | withMultiStatesSA (x :+: xs) k = do 377 | ~(~(a, x'), xs') <- withMultiStates xs $ withMultiState x k 378 | return (x' :+: xs', a) 379 | withMultiStatesA HNil = id 380 | withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x 381 | withMultiStatesS HNil k = k >> return HNil 382 | withMultiStatesS (x :+: xs) k = do 383 | ~(x', xs') <- withMultiStates xs $ withMultiStateS x k 384 | return (x' :+: xs') 385 | withMultiStates_ HNil = void 386 | withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x 387 | 388 | withoutMultiReader :: Monad m => MultiRWST rs w s m a -> MultiRWST (r ': rs) w s m a 389 | withoutMultiReader k = MultiRWST $ get >>= \case 390 | (rs@(_ :+: rr), w, s) -> do 391 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s) 392 | put (rs, w', s') 393 | return a 394 | 395 | withoutMultiState :: Monad m => MultiRWST r w ss m a -> MultiRWST r w (s ': ss) m a 396 | withoutMultiState k = MultiRWST $ get >>= \case 397 | (r, w, s :+: sr) -> do 398 | ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr) 399 | put (r, w', s :+: s') 400 | return a 401 | 402 | inflateReader :: (Monad m, ContainsType r rs) 403 | => ReaderT r m a 404 | -> MultiRWST rs w s m a 405 | inflateReader k = mAsk >>= lift . runReaderT k 406 | inflateMultiReader :: Monad m => MultiReaderT r m a -> MultiRWST r w s m a 407 | inflateMultiReader k = do 408 | r <- mGetRawR 409 | lift $ runMultiReaderT r k 410 | inflateWriter :: (Monad m, ContainsType w ws, Monoid w) 411 | => WriterT w m a 412 | -> MultiRWST r ws s m a 413 | inflateWriter k = do 414 | ~(x, w) <- lift $ runWriterT k 415 | mTell w 416 | return x 417 | inflateMultiWriter :: (Functor m, Monad m, Monoid (HList w)) 418 | => MultiWriterT w m a 419 | -> MultiRWST r w s m a 420 | inflateMultiWriter k = do 421 | ~(x, w) <- lift $ runMultiWriterT k 422 | mPutRawW w 423 | return x 424 | inflateState :: (Monad m, MonadMultiState s (t m), MonadTrans t) 425 | => StateT s m a 426 | -> t m a 427 | inflateState k = do 428 | s <- mGet 429 | ~(x, s') <- lift $ runStateT k s 430 | mSet s' 431 | return x 432 | inflateMultiState :: (Functor m, Monad m) 433 | => MultiStateT s m a 434 | -> MultiRWST r w s m a 435 | inflateMultiState k = do 436 | s <- mGetRawS 437 | ~(x, s') <- lift $ runMultiStateT s k 438 | mPutRawS s' 439 | return x 440 | 441 | mGetRawR :: Monad m => MultiRWST r w s m (HList r) 442 | mPutRawR :: Monad m => HList r -> MultiRWST r w s m () 443 | mGetRawW :: Monad m => MultiRWST r w s m (HList w) 444 | mPutRawW :: Monad m => HList w -> MultiRWST r w s m () 445 | mGetRawS :: Monad m => MultiRWST r w s m (HList s) 446 | mPutRawS :: Monad m => HList s -> MultiRWST r w s m () 447 | mGetRawR = (\(r, _, _) -> r) `liftM` MultiRWST get 448 | mPutRawR r = MultiRWST $ do 449 | ~(_, w, s) <- get 450 | put (r, w, s) 451 | mGetRawW = (\(_, w, _) -> w) `liftM` MultiRWST get 452 | mPutRawW w = MultiRWST $ do 453 | ~(r, _, s) <- get 454 | put (r, w, s) 455 | mGetRawS = (\(_, _, s) -> s) `liftM` MultiRWST get 456 | mPutRawS s = MultiRWST $ do 457 | ~(r, w, _) <- get 458 | put (r, w, s) 459 | 460 | mapMultiRWST :: (ss ~ (HList r, HList w, HList s)) 461 | => (m (a, ss) -> m' (a', ss)) 462 | -> MultiRWST r w s m a 463 | -> MultiRWST r w s m' a' 464 | mapMultiRWST f = MultiRWST . mapStateT f . runMultiRWSTRaw 465 | 466 | -- foreign lifting instances 467 | 468 | instance MonadIO m => MonadIO (MultiRWST r w s m) where 469 | liftIO = lift . liftIO 470 | 471 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiRWST r w s m) where 472 | empty = lift mzero 473 | MultiRWST m <|> MultiRWST n = MultiRWST $ m <|> n 474 | 475 | instance MonadPlus m => MonadPlus (MultiRWST r w s m) where 476 | mzero = MultiRWST $ mzero 477 | MultiRWST m `mplus` MultiRWST n = MultiRWST $ m `mplus` n 478 | 479 | instance MonadBase b m => MonadBase b (MultiRWST r w s m) where 480 | liftBase = liftBaseDefault 481 | 482 | instance MonadTransControl (MultiRWST r w s) where 483 | type StT (MultiRWST r w s) a = (a, (HList r, HList w, HList s)) 484 | liftWith f = MultiRWST $ liftWith $ \s -> f $ \r -> s $ runMultiRWSTRaw r 485 | restoreT = MultiRWST . restoreT 486 | 487 | instance MonadBaseControl b m => MonadBaseControl b (MultiRWST r w s m) where 488 | type StM (MultiRWST r w s m) a = ComposeSt (MultiRWST r w s) m a 489 | liftBaseWith = defaultLiftBaseWith 490 | restoreM = defaultRestoreM 491 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiRWS/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | 7 | -- | The multi-valued version of mtl's RWS / RWST 8 | module Control.Monad.Trans.MultiRWS.Strict 9 | ( 10 | -- * MultiRWST 11 | MultiRWST(..) 12 | , MultiRWSTNull 13 | , MultiRWS 14 | -- * MonadMulti classes 15 | , MonadMultiReader(..) 16 | , MonadMultiWriter(..) 17 | , MonadMultiGet(..) 18 | , MonadMultiState(..) 19 | -- * run-functions (extracting from RWST) 20 | , runMultiRWST 21 | , runMultiRWSTASW 22 | , runMultiRWSTW 23 | , runMultiRWSTAW 24 | , runMultiRWSTSW 25 | , runMultiRWSTNil 26 | , runMultiRWSTNil_ 27 | -- * with-functions (extending an RWST) 28 | , withMultiReader 29 | , withMultiReader_ 30 | , withMultiReaders 31 | , withMultiReaders_ 32 | , withMultiWriter 33 | , withMultiWriterAW 34 | , withMultiWriterWA 35 | , withMultiWriterW 36 | , withMultiWriters 37 | , withMultiWritersAW 38 | , withMultiWritersWA 39 | , withMultiWritersW 40 | , withMultiState 41 | , withMultiStateAS 42 | , withMultiStateSA 43 | , withMultiStateA 44 | , withMultiStateS 45 | , withMultiState_ 46 | , withMultiStates 47 | , withMultiStatesAS 48 | , withMultiStatesSA 49 | , withMultiStatesA 50 | , withMultiStatesS 51 | , withMultiStates_ 52 | -- * without-functions (reducing an RWST; inverse of with) 53 | , withoutMultiReader 54 | , withoutMultiState 55 | -- * inflate-functions (run simple transformer in MultiRWST) 56 | , inflateReader 57 | , inflateMultiReader 58 | , inflateWriter 59 | , inflateMultiWriter 60 | , inflateState 61 | , inflateMultiState 62 | -- * other functions 63 | , mapMultiRWST 64 | , mGetRawR 65 | , mGetRawW 66 | , mGetRawS 67 | , mPutRawR 68 | , mPutRawW 69 | , mPutRawS 70 | ) 71 | where 72 | 73 | 74 | 75 | import Data.HList.HList 76 | import Data.HList.ContainsType 77 | 78 | import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) 79 | import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) 80 | import Control.Monad.Trans.MultiState.Class 81 | import Control.Monad.Trans.MultiReader.Strict ( MultiReaderT(..) 82 | , runMultiReaderT ) 83 | import Control.Monad.Trans.MultiWriter.Strict ( MultiWriterT(..) 84 | , runMultiWriterT ) 85 | import Control.Monad.Trans.MultiState.Strict ( MultiStateT(..) 86 | , runMultiStateT ) 87 | 88 | import Control.Monad.State.Strict ( StateT(..) 89 | , MonadState(..) 90 | , execStateT 91 | , evalStateT 92 | , mapStateT ) 93 | import Control.Monad.Reader ( ReaderT(..) ) 94 | import Control.Monad.Writer.Strict ( WriterT(..) ) 95 | import Control.Monad.Trans.Class ( MonadTrans 96 | , lift ) 97 | 98 | import Data.Functor.Identity ( Identity ) 99 | 100 | import Control.Applicative ( Applicative(..) 101 | , Alternative(..) 102 | ) 103 | import Control.Monad ( MonadPlus(..) 104 | , liftM 105 | , ap 106 | , void ) 107 | import Control.Monad.Base ( MonadBase(..) 108 | , liftBaseDefault 109 | ) 110 | import Control.Monad.Trans.Control ( MonadTransControl(..) 111 | , MonadBaseControl(..) 112 | , ComposeSt 113 | , defaultLiftBaseWith 114 | , defaultRestoreM 115 | ) 116 | import Control.Monad.Fix ( MonadFix(..) ) 117 | import Control.Monad.IO.Class ( MonadIO(..) ) 118 | 119 | import Data.Monoid 120 | 121 | 122 | 123 | newtype MultiRWST r w s m a = MultiRWST { 124 | runMultiRWSTRaw :: StateT (HList r, HList w, HList s) m a 125 | } 126 | 127 | type MultiRWSTNull = MultiRWST '[] '[] '[] 128 | 129 | type MultiRWS r w s = MultiRWST r w s Identity 130 | 131 | instance (Functor f) => Functor (MultiRWST r w s f) where 132 | fmap f = MultiRWST . fmap f . runMultiRWSTRaw 133 | 134 | instance (Applicative m, Monad m) => Applicative (MultiRWST r w s m) where 135 | pure = MultiRWST . pure 136 | (<*>) = ap 137 | 138 | instance (Monad m) => Monad (MultiRWST r w s m) where 139 | return = pure 140 | k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f 141 | 142 | instance MonadTrans (MultiRWST r w s) where 143 | lift = MultiRWST . lift 144 | 145 | instance 146 | #if MIN_VERSION_base(4,8,0) 147 | {-# OVERLAPPING #-} 148 | #endif 149 | (Monad m, ContainsType a r) 150 | => MonadMultiReader a (MultiRWST r w s m) where 151 | mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get 152 | 153 | instance 154 | #if MIN_VERSION_base(4,8,0) 155 | {-# OVERLAPPING #-} 156 | #endif 157 | (Monad m, ContainsType a w, Monoid a) 158 | => MonadMultiWriter a (MultiRWST r w s m) where 159 | mTell v = MultiRWST $ do 160 | (r,w,s) <- get 161 | let !x' = getHListElem w `mappend` v 162 | put $ (r, setHListElem x' w, s) 163 | 164 | instance 165 | #if MIN_VERSION_base(4,8,0) 166 | {-# OVERLAPPING #-} 167 | #endif 168 | (Monad m, ContainsType a s) 169 | => MonadMultiGet a (MultiRWST r w s m) where 170 | mGet = MultiRWST $ do 171 | (_,_,s) <- get 172 | return $ getHListElem s 173 | 174 | instance 175 | #if MIN_VERSION_base(4,8,0) 176 | {-# OVERLAPPING #-} 177 | #endif 178 | (Monad m, ContainsType a s) 179 | => MonadMultiState a (MultiRWST r w s m) where 180 | mSet !v = MultiRWST $ do 181 | (r,w,s) <- get 182 | put (r, w, setHListElem v s) 183 | 184 | instance MonadFix m => MonadFix (MultiRWST r w s m) where 185 | mfix f = MultiRWST $ mfix (runMultiRWSTRaw . f) 186 | 187 | -- methods 188 | 189 | runMultiRWST :: ( Monad m 190 | , Monoid (HList w) 191 | ) 192 | => HList r 193 | -> HList s 194 | -> MultiRWST r w s m a 195 | -> m (a, HList s, HList w) 196 | runMultiRWSTASW :: ( Monad m 197 | , Monoid (HList w) 198 | ) 199 | => HList r 200 | -> HList s 201 | -> MultiRWST r w s m a 202 | -> m (a, HList s, HList w) 203 | runMultiRWSTW :: ( Monad m 204 | , Monoid (HList w) 205 | ) 206 | => HList r 207 | -> HList s 208 | -> MultiRWST r w s m a 209 | -> m (HList w) 210 | runMultiRWSTAW :: ( Monad m 211 | , Monoid (HList w) 212 | ) 213 | => HList r 214 | -> HList s 215 | -> MultiRWST r w s m a 216 | -> m (a, HList w) 217 | runMultiRWSTSW :: ( Monad m 218 | , Monoid (HList w) 219 | ) 220 | => HList r 221 | -> HList s 222 | -> MultiRWST r w s m a 223 | -> m (HList s, HList w) 224 | 225 | runMultiRWSTNil :: ( Monad m ) 226 | => MultiRWST '[] '[] '[] m a 227 | -> m a 228 | runMultiRWSTNil_ :: ( Monad m, Functor m ) 229 | => MultiRWST '[] '[] '[] m a 230 | -> m () 231 | runMultiRWST = runMultiRWSTASW 232 | runMultiRWSTASW r s k = do 233 | (x, (_, w, s')) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) 234 | return $ (x, s', w) 235 | runMultiRWSTW r s k = do 236 | (_, w, _) <- execStateT (runMultiRWSTRaw k) (r, mempty, s) 237 | return $ w 238 | runMultiRWSTAW r s k = do 239 | (x, (_, w, _)) <- runStateT (runMultiRWSTRaw k) (r, mempty, s) 240 | return $ (x, w) 241 | runMultiRWSTSW r s k = do 242 | (_, w, s') <- execStateT (runMultiRWSTRaw k) (r, mempty, s) 243 | return $ (s', w) 244 | runMultiRWSTNil k = evalStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) 245 | runMultiRWSTNil_ k = void $ runStateT (runMultiRWSTRaw k) (HNil, HNil, HNil) 246 | 247 | withMultiReader :: Monad m => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m a 248 | withMultiReader_ :: (Functor m, Monad m) => r -> MultiRWST (r ': rs) w s m a -> MultiRWST rs w s m () 249 | withMultiReaders :: Monad m => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m a 250 | withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiRWST (Append r1 r2) w s m a -> MultiRWST r2 w s m () 251 | withMultiReader x k = MultiRWST $ do 252 | (r, w, s) <- get 253 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (x :+: r, w, s) 254 | put (r, w', s') 255 | return a 256 | withMultiReader_ x k = MultiRWST $ do 257 | (r, w, s) <- get 258 | (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (x :+: r, w, s) 259 | put (r, w', s') 260 | withMultiReaders HNil = id 261 | withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x 262 | withMultiReaders_ HNil = void 263 | withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader x 264 | 265 | withMultiWriter :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) 266 | withMultiWriterAW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (a, w) 267 | withMultiWriterWA :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m (w, a) 268 | withMultiWriterW :: (Monoid w, Monad m) => MultiRWST r (w ': ws) s m a -> MultiRWST r ws s m w 269 | withMultiWriters :: forall r w1 w2 s m a 270 | . (Monoid (HList w1), Monad m, HInit w1) 271 | => MultiRWST r (Append w1 w2) s m a 272 | -> MultiRWST r w2 s m (a, HList w1) 273 | withMultiWritersAW :: forall r w1 w2 s m a 274 | . (Monoid (HList w1), Monad m, HInit w1) 275 | => MultiRWST r (Append w1 w2) s m a 276 | -> MultiRWST r w2 s m (a, HList w1) 277 | withMultiWritersWA :: forall r w1 w2 s m a 278 | . (Monoid (HList w1), Monad m, HInit w1) 279 | => MultiRWST r (Append w1 w2) s m a 280 | -> MultiRWST r w2 s m (HList w1, a) 281 | withMultiWritersW :: forall r w1 w2 s m a 282 | . (Monoid (HList w1), Monad m, HInit w1) 283 | => MultiRWST r (Append w1 w2) s m a 284 | -> MultiRWST r w2 s m (HList w1) 285 | withMultiWriter = withMultiWriterAW 286 | withMultiWriterAW k = MultiRWST $ do 287 | (r, w, s) <- get 288 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) 289 | case w' of 290 | x' :+: wr' -> do 291 | put (r, wr', s') 292 | return (a, x') 293 | withMultiWriterWA k = MultiRWST $ do 294 | (r, w, s) <- get 295 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) 296 | case w' of 297 | x' :+: wr' -> do 298 | put (r, wr', s') 299 | return (x', a) 300 | withMultiWriterW k = MultiRWST $ do 301 | (r, w, s) <- get 302 | (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, mempty :+: w, s) 303 | case w' of 304 | x' :+: wr' -> do 305 | put (r, wr', s') 306 | return x' 307 | withMultiWriters = withMultiWritersAW 308 | withMultiWritersAW k = MultiRWST $ do 309 | (r, w, s) <- get 310 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) 311 | let (o, wr') = hSplit w' 312 | put (r, wr', s') 313 | return (a, o) 314 | withMultiWritersWA k = MultiRWST $ do 315 | (r, w, s) <- get 316 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) 317 | let (o, wr') = hSplit w' 318 | put (r, wr', s') 319 | return (o, a) 320 | withMultiWritersW k = MultiRWST $ do 321 | (r, w, s) <- get 322 | (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, hAppend (mempty :: HList w1) w, s) 323 | let (o, wr') = hSplit w' 324 | put (r, wr', s') 325 | return o 326 | 327 | withMultiState :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) 328 | withMultiStateAS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (a, s) 329 | withMultiStateSA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m (s, a) 330 | withMultiStateA :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m a 331 | withMultiStateS :: Monad m => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m s 332 | withMultiState_ :: (Functor m, Monad m) => s -> MultiRWST r w (s ': ss) m a -> MultiRWST r w ss m () 333 | withMultiStates :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) 334 | withMultiStatesAS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (a, HList s1) 335 | withMultiStatesSA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1, a) 336 | withMultiStatesA :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m a 337 | withMultiStatesS :: Monad m => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m (HList s1) 338 | withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiRWST r w (Append s1 s2) m a -> MultiRWST r w s2 m () 339 | withMultiState = withMultiStateAS 340 | withMultiStateAS x k = MultiRWST $ do 341 | (r, w, s) <- get 342 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 343 | case s' of 344 | x' :+: sr' -> do 345 | put (r, w', sr') 346 | return (a, x') 347 | withMultiStateSA x k = MultiRWST $ do 348 | (r, w, s) <- get 349 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 350 | case s' of 351 | x' :+: sr' -> do 352 | put (r, w', sr') 353 | return (x', a) 354 | withMultiStateA x k = MultiRWST $ do 355 | (r, w, s) <- get 356 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 357 | case s' of 358 | _ :+: sr' -> do 359 | put (r, w', sr') 360 | return a 361 | withMultiStateS x k = MultiRWST $ do 362 | (r, w, s) <- get 363 | (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 364 | case s' of 365 | x' :+: sr' -> do 366 | put (r, w', sr') 367 | return x' 368 | withMultiState_ x k = MultiRWST $ do 369 | (r, w, s) <- get 370 | (_, w', s') <- lift $ execStateT (runMultiRWSTRaw k) (r, w, (x :+: s)) 371 | case s' of _ :+: sr' -> put (r, w', sr') 372 | withMultiStates = withMultiStatesAS 373 | withMultiStatesAS HNil k = do a <- k; return (a, HNil) 374 | withMultiStatesAS (x :+: xs) k = do 375 | ((a, x'), xs') <- withMultiStates xs $ withMultiState x k 376 | return (a, x' :+: xs') 377 | withMultiStatesSA HNil k = do a <- k; return (HNil, a) 378 | withMultiStatesSA (x :+: xs) k = do 379 | ((a, x'), xs') <- withMultiStates xs $ withMultiState x k 380 | return (x' :+: xs', a) 381 | withMultiStatesA HNil = id 382 | withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x 383 | withMultiStatesS HNil k = k >> return HNil 384 | withMultiStatesS (x :+: xs) k = do 385 | (x', xs') <- withMultiStates xs $ withMultiStateS x k 386 | return (x' :+: xs') 387 | withMultiStates_ HNil = void 388 | withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x 389 | 390 | withoutMultiReader :: Monad m => MultiRWST rs w s m a -> MultiRWST (r ': rs) w s m a 391 | withoutMultiReader k = MultiRWST $ get >>= \case 392 | (rs@(_ :+: rr), w, s) -> do 393 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s) 394 | put (rs, w', s') 395 | return a 396 | 397 | withoutMultiState :: Monad m => MultiRWST r w ss m a -> MultiRWST r w (s ': ss) m a 398 | withoutMultiState k = MultiRWST $ get >>= \case 399 | (r, w, s :+: sr) -> do 400 | (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr) 401 | put (r, w', s :+: s') 402 | return a 403 | 404 | inflateReader :: (Monad m, ContainsType r rs) 405 | => ReaderT r m a 406 | -> MultiRWST rs w s m a 407 | inflateReader k = mAsk >>= lift . runReaderT k 408 | inflateMultiReader :: Monad m => MultiReaderT r m a -> MultiRWST r w s m a 409 | inflateMultiReader k = do 410 | r <- mGetRawR 411 | lift $ runMultiReaderT r k 412 | inflateWriter :: (Monad m, ContainsType w ws, Monoid w) 413 | => WriterT w m a 414 | -> MultiRWST r ws s m a 415 | inflateWriter k = do 416 | (x, w) <- lift $ runWriterT k 417 | mTell w 418 | return x 419 | inflateMultiWriter :: (Functor m, Monad m, Monoid (HList w)) 420 | => MultiWriterT w m a 421 | -> MultiRWST r w s m a 422 | inflateMultiWriter k = do 423 | (x, w) <- lift $ runMultiWriterT k 424 | mPutRawW w 425 | return x 426 | inflateState :: (Monad m, MonadTrans t, MonadMultiState s (t m)) 427 | => StateT s m a 428 | -> t m a 429 | inflateState k = do 430 | s <- mGet 431 | (x, s') <- lift $ runStateT k s 432 | mSet s' 433 | return x 434 | inflateMultiState :: (Functor m, Monad m) 435 | => MultiStateT s m a 436 | -> MultiRWST r w s m a 437 | inflateMultiState k = do 438 | s <- mGetRawS 439 | (x, s') <- lift $ runMultiStateT s k 440 | mPutRawS s' 441 | return x 442 | 443 | mGetRawR :: Monad m => MultiRWST r w s m (HList r) 444 | mPutRawR :: Monad m => HList r -> MultiRWST r w s m () 445 | mGetRawW :: Monad m => MultiRWST r w s m (HList w) 446 | mPutRawW :: Monad m => HList w -> MultiRWST r w s m () 447 | mGetRawS :: Monad m => MultiRWST r w s m (HList s) 448 | mPutRawS :: Monad m => HList s -> MultiRWST r w s m () 449 | mGetRawR = (\(r, _, _) -> r) `liftM` MultiRWST get 450 | mPutRawR r = MultiRWST $ do 451 | ~(_, w, s) <- get 452 | put (r, w, s) 453 | mGetRawW = (\(_, w, _) -> w) `liftM` MultiRWST get 454 | mPutRawW w = MultiRWST $ do 455 | ~(r, _, s) <- get 456 | put (r, w, s) 457 | mGetRawS = (\(_, _, s) -> s) `liftM` MultiRWST get 458 | mPutRawS s = MultiRWST $ do 459 | ~(r, w, _) <- get 460 | put (r, w, s) 461 | 462 | mapMultiRWST :: (ss ~ (HList r, HList w, HList s)) 463 | => (m (a, ss) -> m' (a', ss)) 464 | -> MultiRWST r w s m a 465 | -> MultiRWST r w s m' a' 466 | mapMultiRWST f = MultiRWST . mapStateT f . runMultiRWSTRaw 467 | 468 | -- foreign lifting instances 469 | 470 | instance MonadIO m => MonadIO (MultiRWST r w s m) where 471 | liftIO = lift . liftIO 472 | 473 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiRWST r w s m) where 474 | empty = lift mzero 475 | MultiRWST m <|> MultiRWST n = MultiRWST $ m <|> n 476 | 477 | instance MonadPlus m => MonadPlus (MultiRWST r w s m) where 478 | mzero = MultiRWST $ mzero 479 | MultiRWST m `mplus` MultiRWST n = MultiRWST $ m `mplus` n 480 | 481 | instance MonadBase b m => MonadBase b (MultiRWST r w s m) where 482 | liftBase = liftBaseDefault 483 | 484 | instance MonadTransControl (MultiRWST r w s) where 485 | type StT (MultiRWST r w s) a = (a, (HList r, HList w, HList s)) 486 | liftWith f = MultiRWST $ liftWith $ \s -> f $ \r -> s $ runMultiRWSTRaw r 487 | restoreT = MultiRWST . restoreT 488 | 489 | instance MonadBaseControl b m => MonadBaseControl b (MultiRWST r w s m) where 490 | type StM (MultiRWST r w s m) a = ComposeSt (MultiRWST r w s) m a 491 | liftBaseWith = defaultLiftBaseWith 492 | restoreM = defaultRestoreM 493 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiReader.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's Reader / ReaderT 2 | -- / MonadReader 3 | module Control.Monad.Trans.MultiReader 4 | ( -- * MultiReaderT 5 | MultiReaderT(..) 6 | , MultiReaderTNull 7 | , MultiReader 8 | -- * MonadMultiReader class 9 | , MonadMultiReader(..) 10 | -- * run-functions 11 | , runMultiReaderT 12 | , runMultiReaderT_ 13 | , runMultiReaderTNil 14 | , runMultiReaderTNil_ 15 | -- * with-functions (single reader) 16 | , withMultiReader 17 | , withMultiReader_ 18 | -- * with-functions (multiple readers) 19 | , withMultiReaders 20 | , withMultiReaders_ 21 | -- * without-function (single reader) 22 | , withoutMultiReader 23 | -- * inflate-function (run ReaderT in MultiReaderT) 24 | , inflateReader 25 | -- * other functions 26 | , mapMultiReaderT 27 | , mGetRaw 28 | , mPutRaw 29 | ) where 30 | 31 | 32 | 33 | -- just re-export 34 | import Control.Monad.Trans.MultiReader.Lazy 35 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiReader/Class.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's MonadReader 2 | module Control.Monad.Trans.MultiReader.Class 3 | ( 4 | -- * MonadMultiReader class 5 | MonadMultiReader(..) 6 | ) 7 | where 8 | 9 | 10 | 11 | import Control.Monad.Trans.Class ( MonadTrans 12 | , lift ) 13 | 14 | 15 | -- | All methods must be defined. 16 | -- 17 | -- The idea is: Any monad stack is instance of @MonadMultiReader a@, iff 18 | -- the stack contains a @MultiReaderT x@ with /a/ element of /x/. 19 | class (Monad m) => MonadMultiReader a m where 20 | mAsk :: m a -- ^ Access to a specific type in the environment. 21 | 22 | instance (MonadTrans t, Monad (t m), MonadMultiReader a m) 23 | => MonadMultiReader a (t m) where 24 | mAsk = lift $ mAsk 25 | 26 | {- 27 | it might make seem straightforward to define the following class that 28 | corresponds to other transformer classes. But while we can define the the 29 | class and its instances, there is a problem we try to use it, assuming that we 30 | do not want to annotate the full type signature of the config: 31 | the type of the config can not be inferred properly. we would need a feature 32 | like "infer, as return type for this function, the only type for 33 | which there exists a valid chain of instance definitions that is needed to 34 | by this function". 35 | In other words, it is impossible to use the mAskRaw function without 36 | binding a concrete type for c, because otherwise the inference runs into 37 | some overlapping instances. 38 | For this reason, I removed this type class and created a non-class function 39 | mAskRaw, for which the type inference works because it involves no 40 | type classes. 41 | lennart spitzner 42 | -} 43 | 44 | --class (Monad m) => MonadMultiReaderRaw c m where 45 | -- mAskRaw :: m (HList c) 46 | 47 | --instance (MonadTrans t, Monad (t m), MonadMultiReaderRaw c m) 48 | -- => MonadMultiReaderRaw c (t m) where 49 | -- mAskRaw = lift $ mAskRaw 50 | 51 | --instance (Monad m) => MonadMultiReaderRaw a (MultiReaderT a m) where 52 | -- mAskRaw = MultiReaderT $ get -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiReader/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | The multi-valued version of mtl's Reader / ReaderT 4 | module Control.Monad.Trans.MultiReader.Lazy 5 | ( 6 | -- * MultiReaderT 7 | MultiReaderT(..) 8 | , MultiReaderTNull 9 | , MultiReader 10 | -- * MonadMultiReader class 11 | , MonadMultiReader(..) 12 | , MonadMultiGet(..) 13 | -- * run-functions 14 | , runMultiReaderT 15 | , runMultiReaderT_ 16 | , runMultiReaderTNil 17 | , runMultiReaderTNil_ 18 | -- * with-functions (single reader) 19 | , withMultiReader 20 | , withMultiReader_ 21 | -- * with-functions (multiple readers) 22 | , withMultiReaders 23 | , withMultiReaders_ 24 | -- * without-function (single reader) 25 | , withoutMultiReader 26 | -- * inflate-function (run ReaderT in MultiReaderT) 27 | , inflateReader 28 | -- * other functions 29 | , mapMultiReaderT 30 | , mGetRaw 31 | , mPutRaw 32 | ) where 33 | 34 | 35 | 36 | import Data.HList.HList 37 | import Data.HList.ContainsType 38 | 39 | import Control.Monad.Trans.MultiReader.Class 40 | import Control.Monad.Trans.MultiState.Class 41 | 42 | import Control.Monad.State.Lazy ( StateT(..) 43 | , MonadState(..) 44 | , evalStateT 45 | , mapStateT ) 46 | import Control.Monad.Reader ( ReaderT(..) ) 47 | import Control.Monad.Trans.Class ( MonadTrans 48 | , lift ) 49 | import Control.Monad.Writer.Class ( MonadWriter 50 | , listen 51 | , tell 52 | , writer 53 | , pass ) 54 | 55 | import Data.Functor.Identity ( Identity ) 56 | 57 | import Control.Applicative ( Applicative(..) 58 | , Alternative(..) 59 | ) 60 | import Control.Monad ( MonadPlus(..) 61 | , liftM 62 | , ap 63 | , void ) 64 | import Control.Monad.Base ( MonadBase(..) 65 | , liftBaseDefault 66 | ) 67 | import Control.Monad.Trans.Control ( MonadTransControl(..) 68 | , MonadBaseControl(..) 69 | , ComposeSt 70 | , defaultLiftBaseWith 71 | , defaultRestoreM 72 | ) 73 | import Control.Monad.Fix ( MonadFix(..) ) 74 | import Control.Monad.IO.Class ( MonadIO(..) ) 75 | 76 | 77 | 78 | -- | A Reader transformer monad patameterized by: 79 | -- 80 | -- * x - The list of types constituting the environment / input (to be read), 81 | -- * m - The inner monad. 82 | -- 83 | -- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain 84 | -- a heterogenous list of types. 85 | -- 86 | -- This heterogenous list is represented using Types.Data.List, i.e: 87 | -- 88 | -- * @'[]@ - The empty list, 89 | -- * @a ': b@ - A list where @/a/@ is an arbitrary type 90 | -- and @/b/@ is the rest list. 91 | -- 92 | -- For example, 93 | -- 94 | -- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *) 95 | -- 96 | -- is a Reader transformer containing the types [Int, Bool]. 97 | newtype MultiReaderT x m a = MultiReaderT { 98 | runMultiReaderTRaw :: StateT (HList x) m a 99 | } 100 | 101 | -- | A MultiReader transformer carrying an empty state. 102 | type MultiReaderTNull = MultiReaderT '[] 103 | 104 | -- | A reader monad parameterized by the list of types x of the environment 105 | -- / input to carry. 106 | -- 107 | -- Similar to @Reader r = ReaderT r Identity@ 108 | type MultiReader x = MultiReaderT x Identity 109 | 110 | instance (Functor f) => Functor (MultiReaderT x f) where 111 | fmap f = MultiReaderT . fmap f . runMultiReaderTRaw 112 | 113 | instance (Applicative m, Monad m) => Applicative (MultiReaderT x m) where 114 | pure = MultiReaderT . pure 115 | (<*>) = ap 116 | 117 | instance Monad m => Monad (MultiReaderT x m) where 118 | return = pure 119 | k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= runMultiReaderTRaw . f 120 | 121 | instance MonadTrans (MultiReaderT x) where 122 | lift = MultiReaderT . lift 123 | 124 | #if MIN_VERSION_base(4,8,0) 125 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 126 | #else 127 | instance (Monad m, ContainsType a c) 128 | #endif 129 | => MonadMultiReader a (MultiReaderT c m) where 130 | mAsk = MultiReaderT $ liftM getHListElem get 131 | 132 | #if MIN_VERSION_base(4,8,0) 133 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 134 | #else 135 | instance (Monad m, ContainsType a c) 136 | #endif 137 | => MonadMultiGet a (MultiReaderT c m) where 138 | mGet = MultiReaderT $ liftM getHListElem get 139 | 140 | instance MonadFix m => MonadFix (MultiReaderT r m) where 141 | mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) 142 | 143 | -- methods 144 | 145 | -- | A raw extractor of the contained HList (i.e. the complete Reader). 146 | mGetRaw :: Monad m => MultiReaderT a m (HList a) 147 | mGetRaw = MultiReaderT get 148 | 149 | mPutRaw :: Monad m => HList s -> MultiReaderT s m () 150 | mPutRaw = MultiReaderT . put 151 | 152 | -- | Map both the return value and the environment of a computation 153 | -- using the given function. 154 | -- 155 | -- Note that there is a difference to mtl's ReaderT, 156 | -- where it is /not/ possible to modify the environment. 157 | mapMultiReaderT :: (m (a, HList w) -> m' (a', HList w)) 158 | -> MultiReaderT w m a 159 | -> MultiReaderT w m' a' 160 | mapMultiReaderT f = MultiReaderT . mapStateT f . runMultiReaderTRaw 161 | 162 | runMultiReaderT :: Monad m => HList r -> MultiReaderT r m a -> m a 163 | runMultiReaderT_ :: Functor m => HList r -> MultiReaderT r m a -> m () 164 | -- ghc too dumb for this shortcut, unfortunately 165 | -- runMultiReaderT s k = runMultiReaderTNil $ withMultiReaders s k 166 | -- runMultiReaderT_ s k = runMultiReaderTNil $ withMultiReaders_ s k 167 | runMultiReaderT s k = evalStateT (runMultiReaderTRaw k) s 168 | runMultiReaderT_ s k = void $ runStateT (runMultiReaderTRaw k) s 169 | 170 | runMultiReaderTNil :: Monad m => MultiReaderT '[] m a -> m a 171 | runMultiReaderTNil_ :: Functor m => MultiReaderT '[] m a -> m () 172 | runMultiReaderTNil k = evalStateT (runMultiReaderTRaw k) HNil 173 | runMultiReaderTNil_ k = void $ runStateT (runMultiReaderTRaw k) HNil 174 | 175 | withMultiReader :: Monad m => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m a 176 | withMultiReader_ :: (Functor m, Monad m) => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m () 177 | withMultiReader x k = MultiReaderT $ 178 | get >>= lift . evalStateT (runMultiReaderTRaw k) . (x :+:) 179 | withMultiReader_ x k = void $ withMultiReader x k 180 | 181 | withMultiReaders :: Monad m => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m a 182 | withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m () 183 | withMultiReaders HNil = id 184 | withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x 185 | withMultiReaders_ HNil = liftM (const ()) 186 | withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x 187 | 188 | withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a 189 | withoutMultiReader k = MultiReaderT $ get >>= \case 190 | (_ :+: rr) -> lift $ runMultiReaderT rr k 191 | 192 | inflateReader :: (Monad m, ContainsType r rs) 193 | => ReaderT r m a 194 | -> MultiReaderT rs m a 195 | inflateReader k = mAsk >>= lift . runReaderT k 196 | 197 | -- foreign lifting instances 198 | 199 | instance (MonadState s m) => MonadState s (MultiReaderT c m) where 200 | put = lift . put 201 | get = lift $ get 202 | state = lift . state 203 | 204 | instance (MonadWriter w m) => MonadWriter w (MultiReaderT c m) where 205 | writer = lift . writer 206 | tell = lift . tell 207 | listen = MultiReaderT . 208 | mapStateT (liftM (\(~(~(a,w), w')) -> ((a, w'), w)) . listen) . 209 | runMultiReaderTRaw 210 | pass = MultiReaderT . 211 | mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) . 212 | runMultiReaderTRaw 213 | 214 | instance MonadIO m => MonadIO (MultiReaderT c m) where 215 | liftIO = lift . liftIO 216 | 217 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiReaderT c m) where 218 | empty = lift mzero 219 | MultiReaderT m <|> MultiReaderT n = MultiReaderT $ m <|> n 220 | 221 | instance MonadPlus m => MonadPlus (MultiReaderT c m) where 222 | mzero = MultiReaderT $ mzero 223 | MultiReaderT m `mplus` MultiReaderT n = MultiReaderT $ m `mplus` n 224 | 225 | instance MonadBase b m => MonadBase b (MultiReaderT r m) where 226 | liftBase = liftBaseDefault 227 | 228 | instance MonadTransControl (MultiReaderT r) where 229 | type StT (MultiReaderT r) a = (a, HList r) 230 | liftWith f = MultiReaderT $ liftWith $ \s -> f $ \r -> s $ runMultiReaderTRaw r 231 | restoreT = MultiReaderT . restoreT 232 | 233 | instance MonadBaseControl b m => MonadBaseControl b (MultiReaderT r m) where 234 | type StM (MultiReaderT r m) a = ComposeSt (MultiReaderT r) m a 235 | liftBaseWith = defaultLiftBaseWith 236 | restoreM = defaultRestoreM 237 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiReader/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | The multi-valued version of mtl's Reader / ReaderT 4 | module Control.Monad.Trans.MultiReader.Strict 5 | ( 6 | -- * MultiReaderT 7 | MultiReaderT(..) 8 | , MultiReaderTNull 9 | , MultiReader 10 | -- * MonadMultiReader class 11 | , MonadMultiReader(..) 12 | , MonadMultiGet(..) 13 | -- * run-functions 14 | , runMultiReaderT 15 | , runMultiReaderT_ 16 | , runMultiReaderTNil 17 | , runMultiReaderTNil_ 18 | -- * with-functions (single reader) 19 | , withMultiReader 20 | , withMultiReader_ 21 | -- * with-functions (multiple readers) 22 | , withMultiReaders 23 | , withMultiReaders_ 24 | -- * without-function (single reader) 25 | , withoutMultiReader 26 | -- * inflate-function (run ReaderT in MultiReaderT) 27 | , inflateReader 28 | -- * other functions 29 | , mapMultiReaderT 30 | , mGetRaw 31 | , mPutRaw 32 | ) where 33 | 34 | 35 | 36 | import Data.HList.HList 37 | import Data.HList.ContainsType 38 | 39 | import Control.Monad.Trans.MultiReader.Class 40 | import Control.Monad.Trans.MultiState.Class 41 | 42 | import Control.Monad.State.Strict ( StateT(..) 43 | , MonadState(..) 44 | , evalStateT 45 | , mapStateT ) 46 | import Control.Monad.Reader ( ReaderT(..) ) 47 | import Control.Monad.Trans.Class ( MonadTrans 48 | , lift ) 49 | import Control.Monad.Writer.Class ( MonadWriter 50 | , listen 51 | , tell 52 | , writer 53 | , pass ) 54 | 55 | import Data.Functor.Identity ( Identity ) 56 | 57 | import Control.Applicative ( Applicative(..) 58 | , Alternative(..) 59 | ) 60 | import Control.Monad ( MonadPlus(..) 61 | , liftM 62 | , ap 63 | , void ) 64 | import Control.Monad.Base ( MonadBase(..) 65 | , liftBaseDefault 66 | ) 67 | import Control.Monad.Trans.Control ( MonadTransControl(..) 68 | , MonadBaseControl(..) 69 | , ComposeSt 70 | , defaultLiftBaseWith 71 | , defaultRestoreM 72 | ) 73 | import Control.Monad.Fix ( MonadFix(..) ) 74 | import Control.Monad.IO.Class ( MonadIO(..) ) 75 | 76 | 77 | 78 | -- | A Reader transformer monad patameterized by: 79 | -- 80 | -- * x - The list of types constituting the environment / input (to be read), 81 | -- * m - The inner monad. 82 | -- 83 | -- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain 84 | -- a heterogenous list of types. 85 | -- 86 | -- This heterogenous list is represented using Types.Data.List, i.e: 87 | -- 88 | -- * @'[]@ - The empty list, 89 | -- * @a ': b@ - A list where @/a/@ is an arbitrary type 90 | -- and @/b/@ is the rest list. 91 | -- 92 | -- For example, 93 | -- 94 | -- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *) 95 | -- 96 | -- is a Reader transformer containing the types [Int, Bool]. 97 | newtype MultiReaderT x m a = MultiReaderT { 98 | runMultiReaderTRaw :: StateT (HList x) m a 99 | } 100 | 101 | -- | A MultiReader transformer carrying an empty state. 102 | type MultiReaderTNull = MultiReaderT '[] 103 | 104 | -- | A reader monad parameterized by the list of types x of the environment 105 | -- / input to carry. 106 | -- 107 | -- Similar to @Reader r = ReaderT r Identity@ 108 | type MultiReader x = MultiReaderT x Identity 109 | 110 | instance (Functor f) => Functor (MultiReaderT x f) where 111 | fmap f = MultiReaderT . fmap f . runMultiReaderTRaw 112 | 113 | instance (Applicative m, Monad m) => Applicative (MultiReaderT x m) where 114 | pure = MultiReaderT . pure 115 | (<*>) = ap 116 | 117 | instance Monad m => Monad (MultiReaderT x m) where 118 | return = pure 119 | k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= (runMultiReaderTRaw . f) 120 | 121 | instance MonadTrans (MultiReaderT x) where 122 | lift = MultiReaderT . lift 123 | 124 | #if MIN_VERSION_base(4,8,0) 125 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 126 | #else 127 | instance (Monad m, ContainsType a c) 128 | #endif 129 | => MonadMultiReader a (MultiReaderT c m) where 130 | mAsk = MultiReaderT $ liftM getHListElem get 131 | 132 | #if MIN_VERSION_base(4,8,0) 133 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 134 | #else 135 | instance (Monad m, ContainsType a c) 136 | #endif 137 | => MonadMultiGet a (MultiReaderT c m) where 138 | mGet = MultiReaderT $ liftM getHListElem get 139 | 140 | instance MonadFix m => MonadFix (MultiReaderT r m) where 141 | mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) 142 | 143 | -- methods 144 | 145 | -- | A raw extractor of the contained HList (i.e. the complete Reader). 146 | mGetRaw :: Monad m => MultiReaderT a m (HList a) 147 | mGetRaw = MultiReaderT get 148 | 149 | mPutRaw :: Monad m => HList s -> MultiReaderT s m () 150 | mPutRaw = MultiReaderT . put 151 | 152 | -- | Map both the return value and the environment of a computation 153 | -- using the given function. 154 | -- 155 | -- Note that there is a difference to mtl's ReaderT, 156 | -- where it is /not/ possible to modify the environment. 157 | mapMultiReaderT :: (m (a, HList w) -> m' (a', HList w)) 158 | -> MultiReaderT w m a 159 | -> MultiReaderT w m' a' 160 | mapMultiReaderT f = MultiReaderT . mapStateT f . runMultiReaderTRaw 161 | 162 | runMultiReaderT :: Monad m => HList r -> MultiReaderT r m a -> m a 163 | runMultiReaderT_ :: Functor m => HList r -> MultiReaderT r m a -> m () 164 | -- ghc too dumb for this shortcut, unfortunately 165 | -- runMultiReaderT s k = runMultiReaderTNil $ withMultiReaders s k 166 | -- runMultiReaderT_ s k = runMultiReaderTNil $ withMultiReaders_ s k 167 | runMultiReaderT s k = evalStateT (runMultiReaderTRaw k) s 168 | runMultiReaderT_ s k = void $ runStateT (runMultiReaderTRaw k) s 169 | 170 | runMultiReaderTNil :: Monad m => MultiReaderT '[] m a -> m a 171 | runMultiReaderTNil_ :: Functor m => MultiReaderT '[] m a -> m () 172 | runMultiReaderTNil k = evalStateT (runMultiReaderTRaw k) HNil 173 | runMultiReaderTNil_ k = void $ runStateT (runMultiReaderTRaw k) HNil 174 | 175 | withMultiReader :: Monad m => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m a 176 | withMultiReader_ :: (Functor m, Monad m) => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m () 177 | withMultiReader x k = MultiReaderT $ 178 | get >>= lift . evalStateT (runMultiReaderTRaw k) . (x :+:) 179 | withMultiReader_ x k = void $ withMultiReader x k 180 | 181 | withMultiReaders :: Monad m => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m a 182 | withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m () 183 | withMultiReaders HNil = id 184 | withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x 185 | withMultiReaders_ HNil = liftM (const ()) 186 | withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x 187 | 188 | withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a 189 | withoutMultiReader k = MultiReaderT $ get >>= \case 190 | (_ :+: rr) -> lift $ runMultiReaderT rr k 191 | 192 | inflateReader :: (Monad m, ContainsType r rs) 193 | => ReaderT r m a 194 | -> MultiReaderT rs m a 195 | inflateReader k = mAsk >>= lift . runReaderT k 196 | 197 | -- foreign lifting instances 198 | 199 | instance (MonadState s m) => MonadState s (MultiReaderT c m) where 200 | put = lift . put 201 | get = lift $ get 202 | state = lift . state 203 | 204 | instance (MonadWriter w m) => MonadWriter w (MultiReaderT c m) where 205 | writer = lift . writer 206 | tell = lift . tell 207 | listen = MultiReaderT . 208 | mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . 209 | runMultiReaderTRaw 210 | pass = MultiReaderT . 211 | mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . 212 | runMultiReaderTRaw 213 | 214 | instance MonadIO m => MonadIO (MultiReaderT c m) where 215 | liftIO = lift . liftIO 216 | 217 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiReaderT c m) where 218 | empty = lift mzero 219 | MultiReaderT m <|> MultiReaderT n = MultiReaderT $ m <|> n 220 | 221 | instance MonadPlus m => MonadPlus (MultiReaderT c m) where 222 | mzero = MultiReaderT $ mzero 223 | MultiReaderT m `mplus` MultiReaderT n = MultiReaderT $ m `mplus` n 224 | 225 | instance MonadBase b m => MonadBase b (MultiReaderT r m) where 226 | liftBase = liftBaseDefault 227 | 228 | instance MonadTransControl (MultiReaderT r) where 229 | type StT (MultiReaderT r) a = (a, HList r) 230 | liftWith f = MultiReaderT $ liftWith $ \s -> f $ \r -> s $ runMultiReaderTRaw r 231 | restoreT = MultiReaderT . restoreT 232 | 233 | instance MonadBaseControl b m => MonadBaseControl b (MultiReaderT r m) where 234 | type StM (MultiReaderT r m) a = ComposeSt (MultiReaderT r) m a 235 | liftBaseWith = defaultLiftBaseWith 236 | restoreM = defaultRestoreM 237 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiState.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's State / StateT 2 | -- / MonadState 3 | module Control.Monad.Trans.MultiState 4 | ( 5 | -- * MultiStateT 6 | MultiStateT(..) 7 | , MultiStateTNull 8 | , MultiState 9 | -- * MonadMultiState class 10 | , MonadMultiGet(..) 11 | , MonadMultiState(..) 12 | -- * run-functions 13 | , runMultiStateT 14 | , runMultiStateTAS 15 | , runMultiStateTSA 16 | , runMultiStateTA 17 | , runMultiStateTS 18 | , runMultiStateT_ 19 | , runMultiStateTNil 20 | , runMultiStateTNil_ 21 | -- * with-functions (single state) 22 | , withMultiState 23 | , withMultiStateAS 24 | , withMultiStateSA 25 | , withMultiStateA 26 | , withMultiStateS 27 | , withMultiState_ 28 | -- * with-functions (multiple states) 29 | , withMultiStates 30 | , withMultiStatesAS 31 | , withMultiStatesSA 32 | , withMultiStatesA 33 | , withMultiStatesS 34 | , withMultiStates_ 35 | -- * without-function (single state) 36 | , withoutMultiState 37 | -- * inflate-functions (run single state in multiple states) 38 | , inflateState 39 | , inflateReader 40 | , inflateWriter 41 | -- * other functions 42 | , mapMultiStateT 43 | , mGetRaw 44 | , mPutRaw 45 | ) where 46 | 47 | 48 | 49 | -- just re-export 50 | import Control.Monad.Trans.MultiState.Lazy 51 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiState/Class.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's MonadState 2 | module Control.Monad.Trans.MultiState.Class 3 | ( 4 | -- * MonadMultiState class 5 | MonadMultiGet(..) 6 | , MonadMultiState(..) 7 | ) 8 | where 9 | 10 | 11 | 12 | import Control.Monad.Trans.MultiGet.Class 13 | 14 | import Control.Monad.Trans.Class ( MonadTrans 15 | , lift ) 16 | 17 | 18 | 19 | -- The idea is: Any monad stack is instance of @MonadMultiState a@, iff 20 | -- the stack contains a @MultiStateT s m@ with /a/ element of /s/, 21 | -- or a @MultiRWST r w s m@ with /a/ element of /s/. 22 | class (MonadMultiGet a m) => MonadMultiState a m where 23 | mSet :: a -> m () 24 | 25 | instance (MonadTrans t, Monad (t m), MonadMultiState a m) 26 | => MonadMultiState a (t m) where 27 | mSet = lift . mSet 28 | 29 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiState/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | The multi-valued version of mtl's State / StateT 4 | module Control.Monad.Trans.MultiState.Lazy 5 | ( 6 | -- * MultiStateT 7 | MultiStateT(..) 8 | , MultiStateTNull 9 | , MultiState 10 | -- * MonadMultiState class 11 | , MonadMultiGet(..) 12 | , MonadMultiState(..) 13 | -- * run-functions 14 | , runMultiStateT 15 | , runMultiStateTAS 16 | , runMultiStateTSA 17 | , runMultiStateTA 18 | , runMultiStateTS 19 | , runMultiStateT_ 20 | , runMultiStateTNil 21 | , runMultiStateTNil_ 22 | -- * with-functions (single state) 23 | , withMultiState 24 | , withMultiStateAS 25 | , withMultiStateSA 26 | , withMultiStateA 27 | , withMultiStateS 28 | , withMultiState_ 29 | -- * with-functions (multiple states) 30 | , withMultiStates 31 | , withMultiStatesAS 32 | , withMultiStatesSA 33 | , withMultiStatesA 34 | , withMultiStatesS 35 | , withMultiStates_ 36 | -- * without-function (single state) 37 | , withoutMultiState 38 | -- * inflate-functions (run single state in multiple states) 39 | , inflateState 40 | , inflateReader 41 | , inflateWriter 42 | -- * other functions 43 | , mapMultiStateT 44 | , mGetRaw 45 | , mPutRaw 46 | ) where 47 | 48 | 49 | 50 | import Data.HList.HList 51 | import Data.HList.ContainsType 52 | 53 | import Control.Monad.Trans.MultiState.Class 54 | 55 | import Control.Monad.State.Lazy ( StateT(..) 56 | , MonadState(..) 57 | , evalStateT 58 | , execStateT 59 | , mapStateT ) 60 | import Control.Monad.Reader ( ReaderT(..) ) 61 | import Control.Monad.Writer.Lazy ( WriterT(..) ) 62 | import Control.Monad.Trans.Class ( MonadTrans 63 | , lift ) 64 | import Control.Monad.Writer.Class ( MonadWriter 65 | , listen 66 | , tell 67 | , writer 68 | , pass ) 69 | 70 | import Data.Functor.Identity ( Identity ) 71 | 72 | import Control.Applicative ( Applicative(..) 73 | , Alternative(..) 74 | ) 75 | import Control.Monad ( MonadPlus(..) 76 | , liftM 77 | , ap 78 | , void ) 79 | import Control.Monad.Base ( MonadBase(..) 80 | , liftBaseDefault 81 | ) 82 | import Control.Monad.Trans.Control ( MonadTransControl(..) 83 | , MonadBaseControl(..) 84 | , ComposeSt 85 | , defaultLiftBaseWith 86 | , defaultRestoreM 87 | ) 88 | import Data.Monoid ( Monoid ) 89 | import Control.Monad.Fix ( MonadFix(..) ) 90 | import Control.Monad.IO.Class ( MonadIO(..) ) 91 | 92 | 93 | 94 | -- | A State transformer monad patameterized by: 95 | -- 96 | -- * x - The list of types constituting the state, 97 | -- * m - The inner monad. 98 | -- 99 | -- 'MultiStateT' corresponds to mtl's 'StateT', but can contain 100 | -- a heterogenous list of types. 101 | -- 102 | -- This heterogenous list is represented using Types.Data.List, i.e: 103 | -- 104 | -- * @'[]@ - The empty list, 105 | -- * @a ': b@ - A list where @/a/@ is an arbitrary type 106 | -- and @/b/@ is the rest list. 107 | -- 108 | -- For example, 109 | -- 110 | -- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *) 111 | -- 112 | -- is a State wrapper containing the types [Int, Bool]. 113 | newtype MultiStateT x m a = MultiStateT { 114 | runMultiStateTRaw :: StateT (HList x) m a 115 | } 116 | 117 | -- | A MultiState transformer carrying an empty state. 118 | type MultiStateTNull = MultiStateT '[] 119 | 120 | -- | A state monad parameterized by the list of types x of the state to carry. 121 | -- 122 | -- Similar to @State s = StateT s Identity@ 123 | type MultiState x = MultiStateT x Identity 124 | 125 | -- some instances 126 | 127 | instance (Functor f) => Functor (MultiStateT x f) where 128 | fmap f = MultiStateT . fmap f . runMultiStateTRaw 129 | 130 | instance (Applicative m, Monad m) => Applicative (MultiStateT x m) where 131 | pure = MultiStateT . pure 132 | (<*>) = ap 133 | 134 | instance Monad m => Monad (MultiStateT x m) where 135 | return = pure 136 | k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) 137 | 138 | instance MonadTrans (MultiStateT x) where 139 | lift = MultiStateT . lift 140 | 141 | #if MIN_VERSION_base(4,8,0) 142 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 143 | #else 144 | instance (Monad m, ContainsType a c) 145 | #endif 146 | => MonadMultiGet a (MultiStateT c m) where 147 | mGet = MultiStateT $ liftM getHListElem get 148 | 149 | #if MIN_VERSION_base(4,8,0) 150 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 151 | #else 152 | instance (Monad m, ContainsType a c) 153 | #endif 154 | => MonadMultiState a (MultiStateT c m) where 155 | mSet v = MultiStateT $ get >>= put . setHListElem v 156 | 157 | instance MonadFix m => MonadFix (MultiStateT s m) where 158 | mfix f = MultiStateT $ mfix (runMultiStateTRaw . f) 159 | 160 | -- methods 161 | 162 | -- | A raw extractor of the contained HList (i.e. the complete state). 163 | mGetRaw :: Monad m => MultiStateT a m (HList a) 164 | mGetRaw = MultiStateT get 165 | 166 | mPutRaw :: Monad m => HList s -> MultiStateT s m () 167 | mPutRaw = MultiStateT . put 168 | 169 | -- | Map both the return value and the state of a computation 170 | -- using the given function. 171 | mapMultiStateT :: (m (a, HList w) -> m' (a', HList w)) 172 | -> MultiStateT w m a 173 | -> MultiStateT w m' a' 174 | mapMultiStateT f = MultiStateT . mapStateT f . runMultiStateTRaw 175 | 176 | runMultiStateT :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) 177 | runMultiStateTAS :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) 178 | runMultiStateTSA :: Monad m => HList s -> MultiStateT s m a -> m (HList s, a) 179 | runMultiStateTA :: Monad m => HList s -> MultiStateT s m a -> m a 180 | runMultiStateTS :: Monad m => HList s -> MultiStateT s m a -> m (HList s) 181 | runMultiStateT_ :: Functor m => HList s -> MultiStateT s m a -> m () 182 | -- ghc too dumb for this shortcut, unfortunately 183 | -- runMultiStateT s k = runMultiStateTNil $ withMultiStates s k 184 | -- runMultiStateTAS s k = runMultiStateTNil $ withMultiStatesAS s k 185 | -- runMultiStateTSA s k = runMultiStateTNil $ withMultiStatesSA s k 186 | -- runMultiStateTA s k = runMultiStateTNil $ withMultiStatesA s k 187 | -- runMultiStateTS s k = runMultiStateTNil $ withMultiStatesS s k 188 | -- runMultiStateT_ s k = runMultiStateTNil $ withMultiStates_ s k 189 | runMultiStateT s k = runMultiStateTAS s k 190 | runMultiStateTAS s k = runStateT (runMultiStateTRaw k) s 191 | runMultiStateTSA s k = (\(~(a,b)) -> (b,a)) `liftM` runStateT (runMultiStateTRaw k) s 192 | runMultiStateTA s k = evalStateT (runMultiStateTRaw k) s 193 | runMultiStateTS s k = execStateT (runMultiStateTRaw k) s 194 | runMultiStateT_ s k = void $ runStateT (runMultiStateTRaw k) s 195 | 196 | runMultiStateTNil :: Monad m => MultiStateT '[] m a -> m a 197 | runMultiStateTNil_ :: Functor m => MultiStateT '[] m a -> m () 198 | runMultiStateTNil k = evalStateT (runMultiStateTRaw k) HNil 199 | runMultiStateTNil_ k = void $ runStateT (runMultiStateTRaw k) HNil 200 | 201 | withMultiState :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) 202 | withMultiStateAS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) 203 | withMultiStateSA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (s, a) 204 | withMultiStateA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m a 205 | withMultiStateS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m s 206 | withMultiState_ :: (Functor m, Monad m) => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m () 207 | withMultiState = withMultiStateAS 208 | withMultiStateAS x k = MultiStateT $ do 209 | s <- get 210 | ~(a, s') <- lift $ runStateT (runMultiStateTRaw k) (x :+: s) 211 | case s' of x' :+: sr' -> do put sr'; return (a, x') 212 | withMultiStateSA s k = (\(~(a,b)) -> (b,a)) `liftM` withMultiStateAS s k 213 | withMultiStateA s k = fst `liftM` withMultiStateAS s k 214 | withMultiStateS s k = snd `liftM` withMultiStateAS s k 215 | withMultiState_ s k = void $ withMultiStateAS s k 216 | 217 | withMultiStates :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) 218 | withMultiStatesAS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) 219 | withMultiStatesSA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1, a) 220 | withMultiStatesA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m a 221 | withMultiStatesS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1) 222 | withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m () 223 | withMultiStates = withMultiStatesAS 224 | withMultiStatesAS HNil = liftM (\r -> (r, HNil)) 225 | withMultiStatesAS (x :+: xs) = liftM (\(~(~(a, x'), xs')) -> (a, x' :+: xs')) 226 | . withMultiStatesAS xs 227 | . withMultiStateAS x 228 | withMultiStatesSA HNil = liftM (\r -> (HNil, r)) 229 | withMultiStatesSA (x :+: xs) = liftM (\(~(~(a, x'), xs')) -> (x' :+: xs', a)) 230 | . withMultiStatesAS xs 231 | . withMultiStateAS x 232 | withMultiStatesA HNil = id 233 | withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x 234 | withMultiStatesS HNil = liftM (const HNil) 235 | withMultiStatesS (x :+: xs) = liftM (\(~(x', xs')) -> x' :+: xs') 236 | . withMultiStatesAS xs 237 | . withMultiStateS x 238 | withMultiStates_ HNil = liftM (const ()) 239 | withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x 240 | 241 | withoutMultiState :: (Functor m, Monad m) => MultiStateT ss m a -> MultiStateT (s ': ss) m a 242 | withoutMultiState k = MultiStateT $ get >>= \case 243 | s :+: sr -> do 244 | ~(a, sr') <- lift $ runMultiStateT sr k 245 | put (s :+: sr') 246 | return a 247 | 248 | inflateState :: (Monad m, ContainsType s ss) 249 | => StateT s m a 250 | -> MultiStateT ss m a 251 | inflateState k = do 252 | s <- mGet 253 | ~(x, s') <- lift $ runStateT k s 254 | mSet s' 255 | return x 256 | 257 | inflateReader :: (Monad m, ContainsType r ss) 258 | => ReaderT r m a 259 | -> MultiStateT ss m a 260 | inflateReader k = mGet >>= lift . runReaderT k 261 | 262 | inflateWriter :: (Monad m, ContainsType w ss, Monoid w) 263 | => WriterT w m a 264 | -> MultiStateT ss m a 265 | inflateWriter k = do 266 | ~(x, w) <- lift $ runWriterT k 267 | mSet w 268 | return x 269 | 270 | -- foreign lifting instances 271 | 272 | instance (MonadState s m) => MonadState s (MultiStateT c m) where 273 | put = lift . put 274 | get = lift $ get 275 | state = lift . state 276 | 277 | instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where 278 | writer = lift . writer 279 | tell = lift . tell 280 | listen = MultiStateT . 281 | mapStateT (liftM (\(~(~(a,w), w')) -> ((a, w'), w)) . listen) . 282 | runMultiStateTRaw 283 | pass = MultiStateT . 284 | mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) . 285 | runMultiStateTRaw 286 | 287 | instance MonadIO m => MonadIO (MultiStateT c m) where 288 | liftIO = lift . liftIO 289 | 290 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiStateT s m) where 291 | empty = lift mzero 292 | MultiStateT m <|> MultiStateT n = MultiStateT $ m <|> n 293 | 294 | instance MonadPlus m => MonadPlus (MultiStateT s m) where 295 | mzero = MultiStateT $ mzero 296 | MultiStateT m `mplus` MultiStateT n = MultiStateT $ m `mplus` n 297 | 298 | instance MonadBase b m => MonadBase b (MultiStateT s m) where 299 | liftBase = liftBaseDefault 300 | 301 | instance MonadTransControl (MultiStateT s) where 302 | type StT (MultiStateT s) a = (a, HList s) 303 | liftWith f = MultiStateT $ liftWith $ \s -> f $ \r -> s $ runMultiStateTRaw r 304 | restoreT = MultiStateT . restoreT 305 | 306 | instance MonadBaseControl b m => MonadBaseControl b (MultiStateT s m) where 307 | type StM (MultiStateT s m) a = ComposeSt (MultiStateT s) m a 308 | liftBaseWith = defaultLiftBaseWith 309 | restoreM = defaultRestoreM 310 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiState/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | The multi-valued version of mtl's State / StateT 4 | module Control.Monad.Trans.MultiState.Strict 5 | ( 6 | -- * MultiStateT 7 | MultiStateT(..) 8 | , MultiStateTNull 9 | , MultiState 10 | -- * MonadMultiState class 11 | , MonadMultiGet(..) 12 | , MonadMultiState(..) 13 | -- * run-functions 14 | , runMultiStateT 15 | , runMultiStateTAS 16 | , runMultiStateTSA 17 | , runMultiStateTA 18 | , runMultiStateTS 19 | , runMultiStateT_ 20 | , runMultiStateTNil 21 | , runMultiStateTNil_ 22 | -- * with-functions (single state) 23 | , withMultiState 24 | , withMultiStateAS 25 | , withMultiStateSA 26 | , withMultiStateA 27 | , withMultiStateS 28 | , withMultiState_ 29 | -- * with-functions (multiple states) 30 | , withMultiStates 31 | , withMultiStatesAS 32 | , withMultiStatesSA 33 | , withMultiStatesA 34 | , withMultiStatesS 35 | , withMultiStates_ 36 | -- * without-function (single state) 37 | , withoutMultiState 38 | -- * inflate-functions (run single state in multiple states) 39 | , inflateState 40 | , inflateReader 41 | , inflateWriter 42 | -- * other functions 43 | , mapMultiStateT 44 | , mGetRaw 45 | , mPutRaw 46 | ) where 47 | 48 | 49 | 50 | import Data.HList.HList 51 | import Data.HList.ContainsType 52 | 53 | import Control.Monad.State.Strict ( StateT(..) 54 | , MonadState(..) 55 | , evalStateT 56 | , execStateT 57 | , mapStateT ) 58 | import Control.Monad.Reader ( ReaderT(..) ) 59 | import Control.Monad.Writer.Strict ( WriterT(..) ) 60 | import Control.Monad.Trans.Class ( MonadTrans 61 | , lift ) 62 | import Control.Monad.Writer.Class ( MonadWriter 63 | , listen 64 | , tell 65 | , writer 66 | , pass ) 67 | import Control.Monad.Trans.MultiState.Class 68 | 69 | 70 | import Data.Functor.Identity ( Identity ) 71 | 72 | import Control.Applicative ( Applicative(..) 73 | , Alternative(..) 74 | ) 75 | import Control.Monad ( MonadPlus(..) 76 | , liftM 77 | , ap 78 | , void ) 79 | import Control.Monad.Base ( MonadBase(..) 80 | , liftBaseDefault 81 | ) 82 | import Control.Monad.Trans.Control ( MonadTransControl(..) 83 | , MonadBaseControl(..) 84 | , ComposeSt 85 | , defaultLiftBaseWith 86 | , defaultRestoreM 87 | ) 88 | import Data.Monoid ( Monoid ) 89 | import Control.Monad.Fix ( MonadFix(..) ) 90 | import Control.Monad.IO.Class ( MonadIO(..) ) 91 | 92 | 93 | 94 | -- | A State transformer monad patameterized by: 95 | -- 96 | -- * x - The list of types constituting the state, 97 | -- * m - The inner monad. 98 | -- 99 | -- 'MultiStateT' corresponds to mtl's 'StateT', but can contain 100 | -- a heterogenous list of types. 101 | -- 102 | -- This heterogenous list is represented using Types.Data.List, i.e: 103 | -- 104 | -- * @'[]@ - The empty list, 105 | -- * @a ': b@ - A list where @/a/@ is an arbitrary type 106 | -- and @/b/@ is the rest list. 107 | -- 108 | -- For example, 109 | -- 110 | -- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *) 111 | -- 112 | -- is a State wrapper containing the types [Int, Bool]. 113 | newtype MultiStateT x m a = MultiStateT { 114 | runMultiStateTRaw :: StateT (HList x) m a 115 | } 116 | 117 | -- | A MultiState transformer carrying an empty state. 118 | type MultiStateTNull = MultiStateT '[] 119 | 120 | -- | A state monad parameterized by the list of types x of the state to carry. 121 | -- 122 | -- Similar to @State s = StateT s Identity@ 123 | type MultiState x = MultiStateT x Identity 124 | 125 | instance (Functor f) => Functor (MultiStateT x f) where 126 | fmap f = MultiStateT . fmap f . runMultiStateTRaw 127 | 128 | instance (Applicative m, Monad m) => Applicative (MultiStateT x m) where 129 | pure = MultiStateT . pure 130 | (<*>) = ap 131 | 132 | instance Monad m => Monad (MultiStateT x m) where 133 | return = pure 134 | k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) 135 | 136 | instance MonadTrans (MultiStateT x) where 137 | lift = MultiStateT . lift 138 | 139 | #if MIN_VERSION_base(4,8,0) 140 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 141 | #else 142 | instance (Monad m, ContainsType a c) 143 | #endif 144 | => MonadMultiGet a (MultiStateT c m) where 145 | mGet = MultiStateT $ liftM getHListElem get 146 | 147 | #if MIN_VERSION_base(4,8,0) 148 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 149 | #else 150 | instance (Monad m, ContainsType a c) 151 | #endif 152 | => MonadMultiState a (MultiStateT c m) where 153 | mSet v = MultiStateT $ get >>= put . setHListElem v 154 | 155 | instance MonadFix m => MonadFix (MultiStateT s m) where 156 | mfix f = MultiStateT $ mfix (runMultiStateTRaw . f) 157 | 158 | -- methods 159 | 160 | -- | A raw extractor of the contained HList (i.e. the complete state). 161 | mGetRaw :: Monad m => MultiStateT a m (HList a) 162 | mGetRaw = MultiStateT get 163 | 164 | mPutRaw :: Monad m => HList s -> MultiStateT s m () 165 | mPutRaw = MultiStateT . put 166 | 167 | -- | Map both the return value and the state of a computation 168 | -- using the given function. 169 | mapMultiStateT :: (m (a, HList w) -> m' (a', HList w)) 170 | -> MultiStateT w m a 171 | -> MultiStateT w m' a' 172 | mapMultiStateT f = MultiStateT . mapStateT f . runMultiStateTRaw 173 | 174 | runMultiStateT :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) 175 | runMultiStateTAS :: Functor m => HList s -> MultiStateT s m a -> m (a, HList s) 176 | runMultiStateTSA :: Monad m => HList s -> MultiStateT s m a -> m (HList s, a) 177 | runMultiStateTA :: Monad m => HList s -> MultiStateT s m a -> m a 178 | runMultiStateTS :: Monad m => HList s -> MultiStateT s m a -> m (HList s) 179 | runMultiStateT_ :: Functor m => HList s -> MultiStateT s m a -> m () 180 | -- ghc too dumb for this shortcut, unfortunately 181 | -- runMultiStateT s k = runMultiStateTNil $ withMultiStates s k 182 | -- runMultiStateTAS s k = runMultiStateTNil $ withMultiStatesAS s k 183 | -- runMultiStateTSA s k = runMultiStateTNil $ withMultiStatesSA s k 184 | -- runMultiStateTA s k = runMultiStateTNil $ withMultiStatesA s k 185 | -- runMultiStateTS s k = runMultiStateTNil $ withMultiStatesS s k 186 | -- runMultiStateT_ s k = runMultiStateTNil $ withMultiStates_ s k 187 | runMultiStateT s k = runMultiStateTAS s k 188 | runMultiStateTAS s k = runStateT (runMultiStateTRaw k) s 189 | runMultiStateTSA s k = (\(a,b) -> (b,a)) `liftM` runStateT (runMultiStateTRaw k) s 190 | runMultiStateTA s k = evalStateT (runMultiStateTRaw k) s 191 | runMultiStateTS s k = execStateT (runMultiStateTRaw k) s 192 | runMultiStateT_ s k = void $ runStateT (runMultiStateTRaw k) s 193 | 194 | runMultiStateTNil :: Monad m => MultiStateT '[] m a -> m a 195 | runMultiStateTNil_ :: Functor m => MultiStateT '[] m a -> m () 196 | runMultiStateTNil k = evalStateT (runMultiStateTRaw k) HNil 197 | runMultiStateTNil_ k = void $ runStateT (runMultiStateTRaw k) HNil 198 | 199 | withMultiState :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) 200 | withMultiStateAS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (a, s) 201 | withMultiStateSA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m (s, a) 202 | withMultiStateA :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m a 203 | withMultiStateS :: Monad m => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m s 204 | withMultiState_ :: (Functor m, Monad m) => s -> MultiStateT (s ': ss) m a -> MultiStateT ss m () 205 | withMultiState = withMultiStateAS 206 | withMultiStateAS x k = MultiStateT $ do 207 | s <- get 208 | (a, s') <- lift $ runStateT (runMultiStateTRaw k) (x :+: s) 209 | case s' of x' :+: sr' -> do put sr'; return (a, x') 210 | withMultiStateSA s k = (\(a,b) -> (b,a)) `liftM` withMultiStateAS s k 211 | withMultiStateA s k = fst `liftM` withMultiStateAS s k 212 | withMultiStateS s k = snd `liftM` withMultiStateAS s k 213 | withMultiState_ s k = void $ withMultiStateAS s k 214 | 215 | withMultiStates :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) 216 | withMultiStatesAS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (a, HList s1) 217 | withMultiStatesSA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1, a) 218 | withMultiStatesA :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m a 219 | withMultiStatesS :: Monad m => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m (HList s1) 220 | withMultiStates_ :: (Functor m, Monad m) => HList s1 -> MultiStateT (Append s1 s2) m a -> MultiStateT s2 m () 221 | withMultiStates = withMultiStatesAS 222 | withMultiStatesAS HNil = liftM (\r -> (r, HNil)) 223 | withMultiStatesAS (x :+: xs) = liftM (\((a, x'), xs') -> (a, x' :+: xs')) 224 | . withMultiStatesAS xs 225 | . withMultiStateAS x 226 | withMultiStatesSA HNil = liftM (\r -> (HNil, r)) 227 | withMultiStatesSA (x :+: xs) = liftM (\((a, x'), xs') -> (x' :+: xs', a)) 228 | . withMultiStatesAS xs 229 | . withMultiStateAS x 230 | withMultiStatesA HNil = id 231 | withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x 232 | withMultiStatesS HNil = liftM (const HNil) 233 | withMultiStatesS (x :+: xs) = liftM (\(x', xs') -> x' :+: xs') 234 | . withMultiStatesAS xs 235 | . withMultiStateS x 236 | withMultiStates_ HNil = liftM (const ()) 237 | withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x 238 | 239 | withoutMultiState :: (Functor m, Monad m) => MultiStateT ss m a -> MultiStateT (s ': ss) m a 240 | withoutMultiState k = MultiStateT $ get >>= \case 241 | s :+: sr -> do 242 | (a, sr') <- lift $ runMultiStateT sr k 243 | put (s :+: sr') 244 | return a 245 | 246 | inflateState :: (Monad m, ContainsType s ss) 247 | => StateT s m a 248 | -> MultiStateT ss m a 249 | inflateState k = do 250 | s <- mGet 251 | (x, s') <- lift $ runStateT k s 252 | mSet s' 253 | return x 254 | 255 | inflateReader :: (Monad m, ContainsType r ss) 256 | => ReaderT r m a 257 | -> MultiStateT ss m a 258 | inflateReader k = mGet >>= lift . runReaderT k 259 | 260 | inflateWriter :: (Monad m, ContainsType w ss, Monoid w) 261 | => WriterT w m a 262 | -> MultiStateT ss m a 263 | inflateWriter k = do 264 | (x, w) <- lift $ runWriterT k 265 | mSet w 266 | return x 267 | 268 | -- foreign lifting instances 269 | 270 | instance (MonadState s m) => MonadState s (MultiStateT c m) where 271 | put = lift . put 272 | get = lift $ get 273 | state = lift . state 274 | 275 | instance (MonadWriter w m) => MonadWriter w (MultiStateT c m) where 276 | writer = lift . writer 277 | tell = lift . tell 278 | listen = MultiStateT . 279 | mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . 280 | runMultiStateTRaw 281 | pass = MultiStateT . 282 | mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . 283 | runMultiStateTRaw 284 | 285 | instance MonadIO m => MonadIO (MultiStateT c m) where 286 | liftIO = lift . liftIO 287 | 288 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiStateT s m) where 289 | empty = lift mzero 290 | MultiStateT m <|> MultiStateT n = MultiStateT $ m <|> n 291 | 292 | instance MonadPlus m => MonadPlus (MultiStateT s m) where 293 | mzero = MultiStateT $ mzero 294 | MultiStateT m `mplus` MultiStateT n = MultiStateT $ m `mplus` n 295 | 296 | instance MonadBase b m => MonadBase b (MultiStateT s m) where 297 | liftBase = liftBaseDefault 298 | 299 | instance MonadTransControl (MultiStateT s) where 300 | type StT (MultiStateT s) a = (a, HList s) 301 | liftWith f = MultiStateT $ liftWith $ \s -> f $ \r -> s $ runMultiStateTRaw r 302 | restoreT = MultiStateT . restoreT 303 | 304 | instance MonadBaseControl b m => MonadBaseControl b (MultiStateT s m) where 305 | type StM (MultiStateT s m) a = ComposeSt (MultiStateT s) m a 306 | liftBaseWith = defaultLiftBaseWith 307 | restoreM = defaultRestoreM 308 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiWriter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | The multi-valued version of mtl's Writer / WriterT 4 | -- / MonadWriter 5 | module Control.Monad.Trans.MultiWriter 6 | ( -- * MultiWriterT 7 | MultiWriterT(..) 8 | , MultiWriterTNull 9 | , MultiWriter 10 | -- * MonadMultiWriter class 11 | , MonadMultiWriter(..) 12 | -- * run-functions 13 | , runMultiWriterT 14 | , runMultiWriterTAW 15 | , runMultiWriterTWA 16 | , runMultiWriterTW 17 | , runMultiWriterTNil 18 | , runMultiWriterTNil_ 19 | -- * with-functions (single Writer) 20 | , withMultiWriter 21 | , withMultiWriterAW 22 | , withMultiWriterWA 23 | , withMultiWriterW 24 | -- * with-functions (multiple Writers) 25 | , withMultiWriters 26 | , withMultiWritersAW 27 | , withMultiWritersWA 28 | , withMultiWritersW 29 | -- * other functions 30 | , mapMultiWriterT 31 | , mGetRaw 32 | , mPutRaw 33 | ) 34 | where 35 | 36 | 37 | 38 | -- just re-exports 39 | import Control.Monad.Trans.MultiWriter.Lazy 40 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiWriter/Class.hs: -------------------------------------------------------------------------------- 1 | -- | The multi-valued version of mtl's MonadWriter 2 | module Control.Monad.Trans.MultiWriter.Class 3 | ( 4 | -- * MonadMultiWriter class 5 | MonadMultiWriter(..) 6 | ) 7 | where 8 | 9 | 10 | 11 | import Control.Monad.Trans.Class ( MonadTrans 12 | , lift ) 13 | 14 | import Data.Monoid 15 | 16 | 17 | 18 | -- TODO: some haddock 19 | class (Monad m, Monoid a) => MonadMultiWriter a m where 20 | mTell :: a -> m () 21 | 22 | instance (MonadTrans t, Monad (t m), MonadMultiWriter a m) 23 | => MonadMultiWriter a (t m) where 24 | mTell = lift . mTell 25 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiWriter/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | The multi-valued version of mtl's Writer / WriterT 7 | module Control.Monad.Trans.MultiWriter.Lazy 8 | ( 9 | -- * MultiWriterT 10 | MultiWriterT(..) 11 | , MultiWriterTNull 12 | , MultiWriter 13 | -- * MonadMultiWriter class 14 | , MonadMultiWriter(..) 15 | -- * run-functions 16 | , runMultiWriterT 17 | , runMultiWriterTAW 18 | , runMultiWriterTWA 19 | , runMultiWriterTW 20 | , runMultiWriterTNil 21 | , runMultiWriterTNil_ 22 | -- * with-functions (single Writer) 23 | , withMultiWriter 24 | , withMultiWriterAW 25 | , withMultiWriterWA 26 | , withMultiWriterW 27 | -- * with-functions (multiple Writers) 28 | , withMultiWriters 29 | , withMultiWritersAW 30 | , withMultiWritersWA 31 | , withMultiWritersW 32 | -- * inflate-function (run WriterT in MultiWriterT) 33 | , inflateWriter 34 | -- * other functions 35 | , mapMultiWriterT 36 | , mGetRaw 37 | , mPutRaw 38 | ) 39 | where 40 | 41 | 42 | 43 | import Data.HList.HList 44 | import Data.HList.ContainsType 45 | 46 | import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) 47 | 48 | import Control.Monad.State.Lazy ( StateT(..) 49 | , MonadState(..) 50 | , execStateT 51 | , evalStateT 52 | , mapStateT ) 53 | import Control.Monad.Writer.Lazy ( WriterT(..) ) 54 | import Control.Monad.Trans.Class ( MonadTrans 55 | , lift ) 56 | import Control.Monad.Writer.Class ( MonadWriter 57 | , listen 58 | , tell 59 | , writer 60 | , pass ) 61 | 62 | import Data.Functor.Identity ( Identity ) 63 | 64 | import Control.Applicative ( Applicative(..) 65 | , Alternative(..) 66 | ) 67 | import Control.Monad ( MonadPlus(..) 68 | , liftM 69 | , ap 70 | , void ) 71 | import Control.Monad.Base ( MonadBase(..) 72 | , liftBaseDefault 73 | ) 74 | import Control.Monad.Trans.Control ( MonadTransControl(..) 75 | , MonadBaseControl(..) 76 | , ComposeSt 77 | , defaultLiftBaseWith 78 | , defaultRestoreM 79 | ) 80 | import Control.Monad.Fix ( MonadFix(..) ) 81 | import Control.Monad.IO.Class ( MonadIO(..) ) 82 | 83 | import Data.Monoid 84 | 85 | 86 | 87 | -- | A Writer transformer monad patameterized by: 88 | -- 89 | -- * x - The list of types that can be written (Monoid instances). 90 | -- * m - The inner monad. 91 | -- 92 | -- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain 93 | -- a heterogenous list of types. 94 | -- 95 | -- This heterogenous list is represented using Types.Data.List, i.e: 96 | -- 97 | -- * @'[]@ - The empty list, 98 | -- * @a ': b@ - A list where @/a/@ is an arbitrary type 99 | -- and @/b/@ is the rest list. 100 | -- 101 | -- For example, 102 | -- 103 | -- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *) 104 | -- 105 | -- is a Writer transformer containing the types [Int, Bool]. 106 | newtype MultiWriterT x m a = MultiWriterT { 107 | runMultiWriterTRaw :: StateT (HList x) m a 108 | } 109 | 110 | -- | A MultiWriter transformer carrying an empty state. 111 | type MultiWriterTNull = MultiWriterT '[] 112 | 113 | type MultiWriter x a = MultiWriterT x Identity a 114 | 115 | instance (Functor f) => Functor (MultiWriterT x f) where 116 | fmap f = MultiWriterT . fmap f . runMultiWriterTRaw 117 | 118 | instance (Applicative m, Monad m) => Applicative (MultiWriterT x m) where 119 | pure = MultiWriterT . pure 120 | (<*>) = ap 121 | 122 | instance Monad m => Monad (MultiWriterT x m) where 123 | return = pure 124 | k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw . f) 125 | 126 | instance MonadTrans (MultiWriterT x) where 127 | lift = MultiWriterT . lift 128 | 129 | #if MIN_VERSION_base(4,8,0) 130 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c, Monoid a) 131 | #else 132 | instance (Monad m, ContainsType a c, Monoid a) 133 | #endif 134 | => MonadMultiWriter a (MultiWriterT c m) where 135 | mTell v = MultiWriterT $ do 136 | x <- get 137 | put $ setHListElem (getHListElem x `mappend` v) x 138 | 139 | instance MonadFix m => MonadFix (MultiWriterT w m) where 140 | mfix f = MultiWriterT $ mfix (runMultiWriterTRaw . f) 141 | 142 | -- methods 143 | 144 | -- | A raw extractor of the contained HList (i.e. the complete state). 145 | mGetRaw :: Monad m => MultiWriterT a m (HList a) 146 | mGetRaw = MultiWriterT get 147 | 148 | mPutRaw :: Monad m => HList s -> MultiWriterT s m () 149 | mPutRaw = MultiWriterT . put 150 | 151 | -- | Map both the return value and the state of a computation 152 | -- using the given function. 153 | mapMultiWriterT :: (m (a, HList w) -> m' (a', HList w)) 154 | -> MultiWriterT w m a 155 | -> MultiWriterT w m' a' 156 | mapMultiWriterT f = MultiWriterT . mapStateT f . runMultiWriterTRaw 157 | 158 | runMultiWriterT :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) 159 | runMultiWriterTAW :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) 160 | runMultiWriterTWA :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w, a) 161 | runMultiWriterTW :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w) 162 | runMultiWriterT = runMultiWriterTAW 163 | runMultiWriterTAW k = runStateT (runMultiWriterTRaw k) mempty 164 | runMultiWriterTWA k = (\(~(a,b)) -> (b,a)) `liftM` runStateT (runMultiWriterTRaw k) mempty 165 | runMultiWriterTW k = execStateT (runMultiWriterTRaw k) mempty 166 | 167 | runMultiWriterTNil :: Monad m => MultiWriterT '[] m a -> m a 168 | runMultiWriterTNil_ :: Functor m => MultiWriterT '[] m a -> m () 169 | runMultiWriterTNil k = evalStateT (runMultiWriterTRaw k) HNil 170 | runMultiWriterTNil_ k = void $ runStateT (runMultiWriterTRaw k) HNil 171 | 172 | withMultiWriter :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) 173 | withMultiWriterAW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) 174 | withMultiWriterWA :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (w, a) 175 | withMultiWriterW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m w 176 | withMultiWriter = withMultiWriterAW 177 | withMultiWriterAW k = MultiWriterT $ do 178 | w <- get 179 | ~(a, w') <- lift $ runStateT (runMultiWriterTRaw k) (mempty :+: w) 180 | case w' of x' :+: wr' -> do put wr'; return (a, x') 181 | withMultiWriterWA k = (\(~(a,b)) -> (b,a)) `liftM` withMultiWriterAW k 182 | withMultiWriterW k = snd `liftM` withMultiWriterAW k 183 | 184 | withMultiWriters :: forall w1 w2 m a 185 | . (Monoid (HList w1), Monad m, HInit w1) 186 | => MultiWriterT (Append w1 w2) m a 187 | -> MultiWriterT w2 m (a, HList w1) 188 | withMultiWritersAW :: forall w1 w2 m a 189 | . (Monoid (HList w1), Monad m, HInit w1) 190 | => MultiWriterT (Append w1 w2) m a 191 | -> MultiWriterT w2 m (a, HList w1) 192 | withMultiWritersWA :: forall w1 w2 m a 193 | . (Monoid (HList w1), Monad m, HInit w1) 194 | => MultiWriterT (Append w1 w2) m a 195 | -> MultiWriterT w2 m (HList w1, a) 196 | -- withMultiWritersA would have too much ambiguity for what the ws are 197 | -- (one could use a Proxy, but that does not seem to be worth the effort) 198 | -- same reasoning for withMultiWriters_ 199 | withMultiWritersW :: forall w1 w2 m a 200 | . (Monoid (HList w1), Monad m, HInit w1) 201 | => MultiWriterT (Append w1 w2) m a 202 | -> MultiWriterT w2 m (HList w1) 203 | withMultiWriters = withMultiWritersAW 204 | withMultiWritersAW k = MultiWriterT $ do 205 | w <- get 206 | ~(a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) 207 | let (o, w') = hSplit ws' 208 | put w' 209 | return $ (a, o) 210 | withMultiWritersWA k = MultiWriterT $ do 211 | w <- get 212 | ~(a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) 213 | let (o, w') = hSplit ws' 214 | put w' 215 | return $ (o, a) 216 | withMultiWritersW k = MultiWriterT $ do 217 | w <- get 218 | ws' <- lift $ execStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) 219 | let (o, w') = hSplit ws' 220 | put w' 221 | return $ o 222 | 223 | inflateWriter :: (Monad m, Monoid w, ContainsType w ws) 224 | => WriterT w m a 225 | -> MultiWriterT ws m a 226 | inflateWriter k = do 227 | (x, w) <- lift $ runWriterT k 228 | mTell w 229 | return x 230 | 231 | -- foreign lifting instances 232 | 233 | instance (MonadState s m) => MonadState s (MultiWriterT c m) where 234 | put = lift . put 235 | get = lift $ get 236 | state = lift . state 237 | 238 | instance (MonadWriter w m) => MonadWriter w (MultiWriterT c m) where 239 | writer = lift . writer 240 | tell = lift . tell 241 | listen = MultiWriterT . 242 | mapStateT (liftM (\(~(~(a,w), w')) -> ((a, w'), w)) . listen) . 243 | runMultiWriterTRaw 244 | pass = MultiWriterT . 245 | mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) . 246 | runMultiWriterTRaw 247 | 248 | instance MonadIO m => MonadIO (MultiWriterT c m) where 249 | liftIO = lift . liftIO 250 | 251 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiWriterT c m) where 252 | empty = lift mzero 253 | MultiWriterT m <|> MultiWriterT n = MultiWriterT $ m <|> n 254 | 255 | instance MonadPlus m => MonadPlus (MultiWriterT c m) where 256 | mzero = MultiWriterT $ mzero 257 | MultiWriterT m `mplus` MultiWriterT n = MultiWriterT $ m `mplus` n 258 | 259 | instance MonadBase b m => MonadBase b (MultiWriterT c m) where 260 | liftBase = liftBaseDefault 261 | 262 | instance MonadTransControl (MultiWriterT c) where 263 | type StT (MultiWriterT c) a = (a, HList c) 264 | liftWith f = MultiWriterT $ liftWith $ \s -> f $ \r -> s $ runMultiWriterTRaw r 265 | restoreT = MultiWriterT . restoreT 266 | 267 | instance MonadBaseControl b m => MonadBaseControl b (MultiWriterT c m) where 268 | type StM (MultiWriterT c m) a = ComposeSt (MultiWriterT c) m a 269 | liftBaseWith = defaultLiftBaseWith 270 | restoreM = defaultRestoreM 271 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/MultiWriter/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | The multi-valued version of mtl's Writer / WriterT 7 | module Control.Monad.Trans.MultiWriter.Strict 8 | ( 9 | -- * MultiWriterT 10 | MultiWriterT(..) 11 | , MultiWriterTNull 12 | , MultiWriter 13 | -- * MonadMultiWriter class 14 | , MonadMultiWriter(..) 15 | -- * run-functions 16 | , runMultiWriterT 17 | , runMultiWriterTAW 18 | , runMultiWriterTWA 19 | , runMultiWriterTW 20 | , runMultiWriterTNil 21 | , runMultiWriterTNil_ 22 | -- * with-functions (single Writer) 23 | , withMultiWriter 24 | , withMultiWriterAW 25 | , withMultiWriterWA 26 | , withMultiWriterW 27 | -- * with-functions (multiple Writers) 28 | , withMultiWriters 29 | , withMultiWritersAW 30 | , withMultiWritersWA 31 | , withMultiWritersW 32 | -- * inflate-function (run WriterT in MultiWriterT) 33 | , inflateWriter 34 | -- * other functions 35 | , mapMultiWriterT 36 | , mGetRaw 37 | , mPutRaw 38 | ) 39 | where 40 | 41 | 42 | 43 | import Data.HList.HList 44 | import Data.HList.ContainsType 45 | 46 | import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) ) 47 | 48 | import Control.Monad.State.Strict ( StateT(..) 49 | , MonadState(..) 50 | , execStateT 51 | , evalStateT 52 | , mapStateT ) 53 | import Control.Monad.Writer.Strict ( WriterT(..) ) 54 | import Control.Monad.Trans.Class ( MonadTrans 55 | , lift ) 56 | import Control.Monad.Writer.Class ( MonadWriter 57 | , listen 58 | , tell 59 | , writer 60 | , pass ) 61 | 62 | import Data.Functor.Identity ( Identity ) 63 | 64 | import Control.Applicative ( Applicative(..) 65 | , Alternative(..) 66 | ) 67 | import Control.Monad ( MonadPlus(..) 68 | , liftM 69 | , ap 70 | , void ) 71 | import Control.Monad.Base ( MonadBase(..) 72 | , liftBaseDefault 73 | ) 74 | import Control.Monad.Trans.Control ( MonadTransControl(..) 75 | , MonadBaseControl(..) 76 | , ComposeSt 77 | , defaultLiftBaseWith 78 | , defaultRestoreM 79 | ) 80 | import Control.Monad.Fix ( MonadFix(..) ) 81 | import Control.Monad.IO.Class ( MonadIO(..) ) 82 | 83 | import Data.Monoid 84 | 85 | 86 | 87 | -- | A Writer transformer monad patameterized by: 88 | -- 89 | -- * x - The list of types that can be written (Monoid instances). 90 | -- * m - The inner monad. 91 | -- 92 | -- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain 93 | -- a heterogenous list of types. 94 | -- 95 | -- This heterogenous list is represented using Types.Data.List, i.e: 96 | -- 97 | -- * @'[]@ - The empty list, 98 | -- * @a ': b@ - A list where @/a/@ is an arbitrary type 99 | -- and @/b/@ is the rest list. 100 | -- 101 | -- For example, 102 | -- 103 | -- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *) 104 | -- 105 | -- is a Writer transformer containing the types [Int, Bool]. 106 | newtype MultiWriterT x m a = MultiWriterT { 107 | runMultiWriterTRaw :: StateT (HList x) m a 108 | } 109 | 110 | -- | A MultiWriter transformer carrying an empty state. 111 | type MultiWriterTNull = MultiWriterT '[] 112 | 113 | type MultiWriter x a = MultiWriterT x Identity a 114 | 115 | instance (Functor f) => Functor (MultiWriterT x f) where 116 | fmap f = MultiWriterT . fmap f . runMultiWriterTRaw 117 | 118 | instance (Applicative m, Monad m) => Applicative (MultiWriterT x m) where 119 | pure = MultiWriterT . pure 120 | (<*>) = ap 121 | 122 | instance Monad m => Monad (MultiWriterT x m) where 123 | return = pure 124 | k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw.f) 125 | 126 | instance MonadTrans (MultiWriterT x) where 127 | lift = MultiWriterT . lift 128 | 129 | #if MIN_VERSION_base(4,8,0) 130 | instance {-# OVERLAPPING #-} (Monad m, ContainsType a c, Monoid a) 131 | #else 132 | instance (Monad m, ContainsType a c, Monoid a) 133 | #endif 134 | => MonadMultiWriter a (MultiWriterT c m) where 135 | mTell v = MultiWriterT $ do 136 | x <- get 137 | put $ setHListElem (getHListElem x `mappend` v) x 138 | 139 | instance MonadFix m => MonadFix (MultiWriterT w m) where 140 | mfix f = MultiWriterT $ mfix (runMultiWriterTRaw . f) 141 | 142 | -- methods 143 | 144 | -- | A raw extractor of the contained HList (i.e. the complete state). 145 | mGetRaw :: Monad m => MultiWriterT a m (HList a) 146 | mGetRaw = MultiWriterT get 147 | 148 | mPutRaw :: Monad m => HList s -> MultiWriterT s m () 149 | mPutRaw = MultiWriterT . put 150 | 151 | -- | Map both the return value and the state of a computation 152 | -- using the given function. 153 | mapMultiWriterT :: (m (a, HList w) -> m' (a', HList w)) 154 | -> MultiWriterT w m a 155 | -> MultiWriterT w m' a' 156 | mapMultiWriterT f = MultiWriterT . mapStateT f . runMultiWriterTRaw 157 | 158 | runMultiWriterT :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) 159 | runMultiWriterTAW :: (Monoid (HList w), Functor m) => MultiWriterT w m a -> m (a, HList w) 160 | runMultiWriterTWA :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w, a) 161 | runMultiWriterTW :: (Monoid (HList w), Monad m) => MultiWriterT w m a -> m (HList w) 162 | runMultiWriterT = runMultiWriterTAW 163 | runMultiWriterTAW k = runStateT (runMultiWriterTRaw k) mempty 164 | runMultiWriterTWA k = (\(a,b) -> (b,a)) `liftM` runStateT (runMultiWriterTRaw k) mempty 165 | runMultiWriterTW k = execStateT (runMultiWriterTRaw k) mempty 166 | 167 | runMultiWriterTNil :: Monad m => MultiWriterT '[] m a -> m a 168 | runMultiWriterTNil_ :: Functor m => MultiWriterT '[] m a -> m () 169 | runMultiWriterTNil k = evalStateT (runMultiWriterTRaw k) HNil 170 | runMultiWriterTNil_ k = void $ runStateT (runMultiWriterTRaw k) HNil 171 | 172 | withMultiWriter :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) 173 | withMultiWriterAW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (a, w) 174 | withMultiWriterWA :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m (w, a) 175 | withMultiWriterW :: (Monoid w, Monad m) => MultiWriterT (w ': ws) m a -> MultiWriterT ws m w 176 | withMultiWriter = withMultiWriterAW 177 | withMultiWriterAW k = MultiWriterT $ do 178 | w <- get 179 | (a, w') <- lift $ runStateT (runMultiWriterTRaw k) (mempty :+: w) 180 | case w' of x' :+: wr' -> do put wr'; return (a, x') 181 | withMultiWriterWA k = (\(a,b) -> (b,a)) `liftM` withMultiWriterAW k 182 | withMultiWriterW k = snd `liftM` withMultiWriterAW k 183 | 184 | withMultiWriters :: forall w1 w2 m a 185 | . (Monoid (HList w1), Monad m, HInit w1) 186 | => MultiWriterT (Append w1 w2) m a 187 | -> MultiWriterT w2 m (a, HList w1) 188 | withMultiWritersAW :: forall w1 w2 m a 189 | . (Monoid (HList w1), Monad m, HInit w1) 190 | => MultiWriterT (Append w1 w2) m a 191 | -> MultiWriterT w2 m (a, HList w1) 192 | withMultiWritersWA :: forall w1 w2 m a 193 | . (Monoid (HList w1), Monad m, HInit w1) 194 | => MultiWriterT (Append w1 w2) m a 195 | -> MultiWriterT w2 m (HList w1, a) 196 | -- withMultiWritersA would have too much ambiguity for what the ws are 197 | -- (one could use a Proxy, but that does not seem to be worth the effort) 198 | -- same reasoning for withMultiWriters_ 199 | withMultiWritersW :: forall w1 w2 m a 200 | . (Monoid (HList w1), Monad m, HInit w1) 201 | => MultiWriterT (Append w1 w2) m a 202 | -> MultiWriterT w2 m (HList w1) 203 | withMultiWriters = withMultiWritersAW 204 | withMultiWritersAW k = MultiWriterT $ do 205 | w <- get 206 | (a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) 207 | let (o, w') = hSplit ws' 208 | put w' 209 | return $ (a, o) 210 | withMultiWritersWA k = MultiWriterT $ do 211 | w <- get 212 | (a, ws') <- lift $ runStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) 213 | let (o, w') = hSplit ws' 214 | put w' 215 | return $ (o, a) 216 | withMultiWritersW k = MultiWriterT $ do 217 | w <- get 218 | ws' <- lift $ execStateT (runMultiWriterTRaw k) (hAppend (mempty :: HList w1) w) 219 | let (o, w') = hSplit ws' 220 | put w' 221 | return $ o 222 | 223 | inflateWriter :: (Monad m, Monoid w, ContainsType w ws) 224 | => WriterT w m a 225 | -> MultiWriterT ws m a 226 | inflateWriter k = do 227 | (x, w) <- lift $ runWriterT k 228 | mTell w 229 | return x 230 | 231 | -- foreign lifting instances 232 | 233 | instance (MonadState s m) => MonadState s (MultiWriterT c m) where 234 | put = lift . put 235 | get = lift $ get 236 | state = lift . state 237 | 238 | instance (MonadWriter w m) => MonadWriter w (MultiWriterT c m) where 239 | writer = lift . writer 240 | tell = lift . tell 241 | listen = MultiWriterT . 242 | mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . 243 | runMultiWriterTRaw 244 | pass = MultiWriterT . 245 | mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . 246 | runMultiWriterTRaw 247 | 248 | instance MonadIO m => MonadIO (MultiWriterT c m) where 249 | liftIO = lift . liftIO 250 | 251 | instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiWriterT c m) where 252 | empty = lift mzero 253 | MultiWriterT m <|> MultiWriterT n = MultiWriterT $ m <|> n 254 | 255 | instance MonadPlus m => MonadPlus (MultiWriterT c m) where 256 | mzero = MultiWriterT $ mzero 257 | MultiWriterT m `mplus` MultiWriterT n = MultiWriterT $ m `mplus` n 258 | 259 | instance MonadBase b m => MonadBase b (MultiWriterT c m) where 260 | liftBase = liftBaseDefault 261 | 262 | instance MonadTransControl (MultiWriterT c) where 263 | type StT (MultiWriterT c) a = (a, HList c) 264 | liftWith f = MultiWriterT $ liftWith $ \s -> f $ \r -> s $ runMultiWriterTRaw r 265 | restoreT = MultiWriterT . restoreT 266 | 267 | instance MonadBaseControl b m => MonadBaseControl b (MultiWriterT c m) where 268 | type StM (MultiWriterT c m) a = ComposeSt (MultiWriterT c) m a 269 | liftBaseWith = defaultLiftBaseWith 270 | restoreM = defaultRestoreM 271 | -------------------------------------------------------------------------------- /src/Data/HList/ContainsType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Class to provide type-driven access to elements of a HList 4 | module Data.HList.ContainsType 5 | ( ContainsType(..) 6 | ) 7 | where 8 | 9 | 10 | 11 | import Data.HList.HList 12 | 13 | 14 | 15 | ---------------------------------------- 16 | -- class ContainsType 17 | -- | for get/put of a value in a HList, with type-directed lookup. 18 | class ContainsType a c where 19 | setHListElem :: a -> HList c -> HList c 20 | getHListElem :: HList c -> a 21 | 22 | #if MIN_VERSION_base(4,8,0) 23 | instance {-# OVERLAPPING #-} ContainsType a (a ': xs) where 24 | #else 25 | instance ContainsType a (a ': xs) where 26 | #endif 27 | setHListElem a xs = a :+: case xs of (_ :+: xr) -> xr 28 | getHListElem (x :+: _) = x 29 | 30 | instance (ContainsType a xs) => ContainsType a (x ': xs) where 31 | setHListElem a (x :+: xr) = x :+: setHListElem a xr 32 | getHListElem (_ :+: xr) = getHListElem xr 33 | 34 | -------------------------------------------------------------------------------- /src/Data/HList/HList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | 10 | -- | A GADT HList implementation 11 | -- 12 | -- There exist other implementations of HList on hackage, but none seem to 13 | -- be reliably maintained. 14 | module Data.HList.HList 15 | ( HList(..) 16 | , Append 17 | , hAppend 18 | , HInit(..) 19 | ) where 20 | 21 | 22 | 23 | import Prelude hiding (reverse) 24 | 25 | import Data.Kind (Type) 26 | import Data.Monoid (Monoid, mappend, mempty) 27 | import Data.Semigroup 28 | 29 | import Data.Proxy 30 | 31 | 32 | 33 | data HList :: [Type] -> Type where 34 | HNil :: HList '[] 35 | (:+:) :: x -> HList xs -> HList (x ': xs) 36 | -- TCons :: x -> HList xs -> HList (Cons x xs) 37 | -- TNull :: HList Null 38 | 39 | infixr 5 :+: 40 | 41 | instance Show (HList '[]) where 42 | show _ = "HNil" 43 | 44 | instance (Show a, Show (HList b)) => Show (HList (a ': b)) where 45 | show (x :+: y) = "(" ++ show x ++ ":+:" ++ show y ++ ")" 46 | 47 | instance Semigroup (HList '[]) where 48 | _ <> _ = HNil 49 | instance (Semigroup x, Semigroup (HList xs)) 50 | => Semigroup (HList (x ': xs)) 51 | where 52 | (x1 :+: xs1) <> (x2 :+: xs2) = (x1 <> x2) :+: (xs1 <> xs2) 53 | 54 | instance Monoid (HList '[]) where 55 | mempty = HNil 56 | mappend = (<>) 57 | instance (Semigroup x, Monoid x, Semigroup (HList xs), Monoid (HList xs)) 58 | => Monoid (HList (x ': xs)) 59 | where 60 | mempty = mempty :+: mempty 61 | mappend = (<>) 62 | 63 | instance Eq (HList '[]) where 64 | HNil == HNil = True 65 | HNil /= HNil = False 66 | 67 | instance (Eq x, Eq (HList xs)) 68 | => Eq (HList (x ': xs)) 69 | where 70 | x1 :+: xr1 == x2 :+: xr2 = x1==x2 && xr1==xr2 71 | x1 :+: xr1 /= x2 :+: xr2 = x1/=x2 || xr1/=xr2 72 | 73 | -- cannot use the closed variant because of ghc-7.8.4. 74 | -- (was not investigated more closely; there simply 75 | -- is some syntax error for code which works fine with ghc-7.10.) 76 | type family Append (l1::[Type]) (l2::[Type]) :: [Type] 77 | type instance Append '[] l2 = l2 78 | type instance Append (car1 ': cdr2) l2 = car1 ': Append cdr2 l2 79 | 80 | hAppend :: HList ts1 -> HList ts2 -> HList (Append ts1 ts2) 81 | hAppend HNil l = l 82 | hAppend (x:+:xs) l = x :+: hAppend xs l 83 | 84 | class HInit (l1 :: [Type]) where 85 | hInit :: forall l2 . Proxy l2 -> HList (Append l1 l2) -> HList l1 86 | hSplit :: forall l2 . HList (Append l1 l2) -> (HList l1, HList l2) 87 | 88 | instance HInit '[] where 89 | hInit _ _ = HNil 90 | hSplit l = (HNil, l) 91 | instance HInit l1 => HInit (x ': l1) where 92 | hInit p (x :+: xs) = x :+: hInit p xs 93 | #if !MIN_VERSION_base(4,9,0) 94 | hInit _ _ = error "cannot happen" -- see ghc trac #3927 95 | #endif 96 | hSplit (x :+: xs) = let (l1, l2) = hSplit xs 97 | in (x :+: l1, l2) 98 | #if !MIN_VERSION_base(4,9,0) 99 | hSplit _ = error "cannot happen" 100 | #endif 101 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.13 2 | packages: 3 | - . 4 | extra-deps: [] 5 | -------------------------------------------------------------------------------- /stack-8.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | packages: 3 | - . 4 | extra-deps: [] 5 | -------------------------------------------------------------------------------- /stack-8.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | packages: 3 | - . 4 | extra-deps: [] 5 | -------------------------------------------------------------------------------- /stack-9.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2021-10-01 2 | packages: 3 | - . 4 | extra-deps: [] 5 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 7 | 8 | module Main where 9 | 10 | 11 | 12 | import Data.Functor.Identity 13 | import Data.HList.HList 14 | import Data.Monoid 15 | import Data.Semigroup 16 | 17 | import qualified Control.Monad.Trans.MultiState as MS 18 | import qualified Control.Monad.Trans.MultiReader as MR 19 | import qualified Control.Monad.Trans.MultiWriter as MW 20 | 21 | import Control.Applicative ( Applicative, (<$>), (<*>) ) 22 | 23 | import Test.Hspec 24 | 25 | 26 | 27 | type Tests = [(Bool, String)] 28 | 29 | runEvalMS :: MS.MultiStateT '[] Identity a -> a 30 | runEvalMS = runIdentity . MS.runMultiStateTNil 31 | runEvalMR :: MR.MultiReaderT '[] Identity a -> a 32 | runEvalMR = runIdentity . MR.runMultiReaderTNil 33 | runExecMW :: Monoid (HList x) => MW.MultiWriterT x Identity a -> HList x 34 | runExecMW = runIdentity . MW.runMultiWriterTW 35 | 36 | runnerMS :: a -> MS.MultiStateT '[a] Identity a -> a 37 | runnerMS x m = runEvalMS $ MS.withMultiStateA x m 38 | runnerMR :: a -> MR.MultiReaderT '[a] Identity a -> a 39 | runnerMR x m = runEvalMR $ MR.withMultiReader x m 40 | runnerMW :: (Semigroup a, Monoid a) => MW.MultiWriterT '[a] Identity b -> a 41 | runnerMW m = case runExecMW m of (x :+: _) -> x 42 | -- TODO: ghc bug?: warning on: 43 | -- runnerMW m = case runExecMW m of (x :+: HNil) -> x 44 | 45 | runnerMS_ :: a -> MS.MultiStateT '[a] Identity b -> a 46 | runnerMS_ x m = runIdentity 47 | $ MS.runMultiStateTNil 48 | $ MS.withMultiStateA x (m >> MS.mGet) 49 | runnerMR_ :: a -> MR.MultiReaderT '[a] Identity b -> a 50 | runnerMR_ x m = runIdentity 51 | $ MR.runMultiReaderTNil 52 | $ MR.withMultiReader x (m >> MR.mAsk) 53 | 54 | intRunnerMS :: Int -> MS.MultiStateT '[Int] Identity Int -> Int 55 | intRunnerMS = runnerMS 56 | intRunnerMS_ :: Int -> MS.MultiStateT '[Int] Identity b -> Int 57 | intRunnerMS_ = runnerMS_ 58 | intRunnerMR :: Int -> MR.MultiReaderT '[Int] Identity Int -> Int 59 | intRunnerMR = runnerMR 60 | intRunnerMR_ :: Int -> MR.MultiReaderT '[Int] Identity b -> Int 61 | intRunnerMR_ = runnerMR_ 62 | stringRunnerMW :: MW.MultiWriterT '[String] Identity b -> String 63 | stringRunnerMW = runnerMW 64 | 65 | mrAskTuple :: ( Applicative m 66 | , MR.MonadMultiReader a m 67 | , MR.MonadMultiReader b m) 68 | => m (a,b) 69 | mrAskTuple = (,) <$> MR.mAsk <*> MR.mAsk 70 | msGetTuple :: ( Applicative m 71 | , MS.MonadMultiState a m 72 | , MS.MonadMultiState b m) 73 | => m (a,b) 74 | msGetTuple = (,) <$> MS.mGet <*> MS.mGet 75 | 76 | testsMultiState :: Spec 77 | testsMultiState = do 78 | it "identity" $ 1 `shouldBe` runIdentity (Identity (1::Int)) 79 | it "getConfig" 80 | $ intRunnerMS_ 2 (return ()) 81 | `shouldBe` 2 82 | it "setConfig" 83 | $ intRunnerMS_ 100 (MS.mSet (3::Int)) 84 | `shouldBe` 3 85 | it "setConfig" 86 | $ intRunnerMS_ 4 (MS.mGet >>= \x -> MS.mSet (x::Int)) 87 | `shouldBe` 4 88 | it "nesting 1" 89 | $ intRunnerMS (4::Int) (MS.withMultiStateA (5::Int) MS.mGet) 90 | `shouldBe` 5 91 | it "nesting 2" 92 | $ intRunnerMS (4::Int) ( MS.mSet (100::Int) 93 | >> MS.withMultiStateA (6::Int) MS.mGet) 94 | `shouldBe` 6 95 | it "nesting 3" 96 | $ intRunnerMS (4::Int) (MS.withMultiStateA (100::Int) 97 | $ MS.mSet (7::Int) >> MS.mGet) 98 | `shouldBe` 7 99 | it "multiple types 1" 100 | $ ( runEvalMS 101 | $ MS.withMultiStateA True 102 | $ MS.withMultiStateA 'a' 103 | $ msGetTuple ) 104 | `shouldBe` (True, 'a') 105 | it "multiple types 2" 106 | $ ( runEvalMS 107 | $ MS.withMultiStateA True 108 | $ MS.withMultiStateA 'a' 109 | $ MS.withMultiStateA 'b' 110 | $ msGetTuple ) 111 | `shouldBe` (True, 'b') 112 | it "askRaw" test13MS 113 | 114 | testsMultiReader :: Spec 115 | testsMultiReader = do 116 | it "identity" 117 | $ runIdentity (Identity (1::Int)) 118 | `shouldBe` 1 119 | it "getConfig" 120 | $ intRunnerMR_ 2 (return ()) 121 | `shouldBe` 2 122 | it "nesting" 123 | $ intRunnerMR (4::Int) (MR.withMultiReader (5::Int) MR.mAsk) 124 | `shouldBe` 5 125 | it "multiple types 1" 126 | $ ( runEvalMR 127 | $ MR.withMultiReader True 128 | $ MR.withMultiReader 'a' 129 | $ mrAskTuple ) 130 | `shouldBe` (True, 'a') 131 | it "multiple types 2" 132 | $ ( runEvalMR 133 | $ MR.withMultiReader True 134 | $ MR.withMultiReader 'a' 135 | $ MR.withMultiReader 'b' 136 | $ mrAskTuple ) 137 | `shouldBe` (True, 'b') 138 | it "multiple types 3" 139 | $ ( runEvalMR 140 | $ MR.withMultiReader True 141 | $ MR.withMultiReader 'a' 142 | $ MR.withMultiReader False 143 | $ mrAskTuple ) 144 | `shouldBe` (False, 'a') 145 | it "getRaw" test13MR 146 | 147 | testsMultiWriter :: Spec 148 | testsMultiWriter = do 149 | it "1-0" 150 | $ stringRunnerMW (return ()) 151 | `shouldBe` "" 152 | it "1-1" 153 | $ stringRunnerMW (MW.mTell "a") 154 | `shouldBe` "a" 155 | it "1-2" 156 | $ stringRunnerMW (MW.mTell "a" >> MW.mTell "b") 157 | `shouldBe` "ab" 158 | it "2" 159 | $ runExecMW (MW.mTell "a" >> MW.mTell [True] >> MW.mTell "b") 160 | `shouldBe` ("ab" :+: [True] :+: HNil) 161 | 162 | tests :: Spec 163 | tests = do 164 | describe "MultiState" $ testsMultiState 165 | describe "MultiReader" $ testsMultiReader 166 | describe "MultiWriter" $ testsMultiWriter 167 | lazyStateTest 168 | 169 | test13MR :: Bool 170 | test13MR = runIdentity 171 | $ MR.runMultiReaderTNil 172 | $ MR.withMultiReader True 173 | $ MR.withMultiReader 'a' 174 | $ do 175 | c <- MR.mGetRaw 176 | return $ runIdentity 177 | $ MR.runMultiReaderTNil 178 | $ MR.withMultiReaders c 179 | $ do 180 | b <- MR.mAsk 181 | return (b::Bool) 182 | 183 | test13MS :: Bool 184 | test13MS = runIdentity 185 | $ MS.runMultiStateTNil 186 | $ MS.withMultiStateA True 187 | $ MS.withMultiStateA 'a' 188 | $ do 189 | c <- MS.mGetRaw 190 | return $ runIdentity 191 | $ MS.runMultiStateTNil 192 | $ MS.withMultiStatesA c 193 | $ do 194 | b <- MS.mGet 195 | return (b::Bool) 196 | 197 | lazyStateTest :: Spec 198 | lazyStateTest = it "lazyStateTest" $ (33, True) `shouldBe` l 199 | where 200 | l :: (Int, Bool) 201 | l = case runIdentity $ MS.runMultiStateTS ([] :+: [] :+: HNil) action of 202 | (x :+: y :+: _) -> (head x, head y) 203 | #if !MIN_VERSION_base(4,9,0) 204 | _ -> error "some ghc versions think that above is not exhaustive." 205 | #endif 206 | action :: MS.MultiStateT '[[Int], [Bool]] Identity () 207 | action = do 208 | action 209 | x <- MS.mGet 210 | MS.mSet $ (33::Int):x 211 | y <- MS.mGet 212 | MS.mSet $ True:y 213 | 214 | 215 | main :: IO () 216 | main = hspec $ tests 217 | -- mapM_ (putStrLn . ("error: "++) . snd) $ filter (\(b, _) -> not b) tests 218 | -- putStrLn $ "ran " 219 | -- ++ show (length tests) 220 | -- ++ " tests (no further output = good)" 221 | -- return () 222 | 223 | {- 224 | 225 | main = do 226 | evalStateT 227 | (runMultiReaderT $ withConfig 'a' $ do 228 | x <- withConfig 'b' getConfig 229 | lift $ lift $ print (x::Char) 230 | y <- get 231 | lift $ lift $ print (y::Int) 232 | return () 233 | ) 234 | (1::Int) 235 | runMultiReaderT $ withConfig 'a' $ evalStateT 236 | ( do 237 | x <- getConfig 238 | lift $ lift $ print (x::Char) 239 | y <- get 240 | lift $ lift $ print (y::Int) 241 | return () 242 | ) 243 | (1::Int) 244 | 245 | main = do 246 | evalStateT 247 | (evalMultiStateT $ withConfig 'a' $ do 248 | x <- withConfig 'b' getConfig 249 | lift $ lift $ print (x::Char) 250 | y <- get 251 | lift $ lift $ print (y::Int) 252 | return () 253 | ) 254 | (1::Int) 255 | evalMultiStateT $ withConfig 'a' $ evalStateT 256 | ( do 257 | x <- getConfig 258 | lift $ lift $ print (x::Char) 259 | y <- get 260 | lift $ lift $ print (y::Int) 261 | return () 262 | ) 263 | (1::Int) 264 | 265 | -} --------------------------------------------------------------------------------