├── Setup.hs ├── Control └── Monad │ ├── Classes │ ├── Effects.hs │ ├── Exec.hs │ ├── Run.hs │ ├── Except.hs │ ├── Core.hs │ ├── ReadState.hs │ ├── Proxied.hs │ ├── Zoom.hs │ ├── State.hs │ ├── Reader.hs │ └── Writer.hs │ └── Classes.hs ├── CONTRIBUTING.md ├── LICENSE ├── stack.yaml ├── .travis.yml ├── README.md ├── monad-classes.cabal └── tests └── test.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Effects.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.Effects where 2 | 3 | -- | Writer effect 4 | data EffWriter (w :: *) 5 | 6 | -- | Reader effect 7 | data EffReader (e :: *) 8 | 9 | -- | Local state change effect 10 | data EffLocal (e :: *) 11 | 12 | -- | State effect 13 | data EffState (s :: *) 14 | 15 | -- | Arbitrary monadic effect 16 | data EffExec (w :: * -> *) 17 | 18 | -- | Except effect 19 | data EffExcept (e :: *) 20 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repo serves two purposes: 2 | 3 | * as a reference implementation accompanying the [series of articles on 4 | extensible effects][1] 5 | * as an actual implementation we use at [Signal Vine](http://signalvine.com/) 6 | 7 | While this is technically open source software, I am not interested in maintaining this as 8 | an active open project. In practice this means that: 9 | 10 | * this version of monad-classes is not on hackage 11 | * I do not accept feature requests and pull requests. The exception is outright 12 | bugs; if you find any, please do report them. 13 | 14 | There is a [hackage package][2] and a [repo][3] maintained by M Farkas-Dyck. 15 | 16 | [1]: https://ro-che.info/articles/extensible-effects 17 | [2]: https://hackage.haskell.org/package/monad-classes 18 | [3]: https://github.com/strake/monad-classes.hs 19 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Exec.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.Exec 2 | ( MonadExec 3 | , exec 4 | , MonadExecN(..) 5 | , EffExec 6 | ) 7 | where 8 | import Control.Monad.Trans.Class 9 | import GHC.Prim (Proxy#, proxy#) 10 | import Control.Monad.Classes.Core 11 | import Control.Monad.Classes.Effects 12 | 13 | type instance CanDo IO (EffExec IO) = 'True 14 | 15 | class Monad m => MonadExecN (n :: Nat) w m where 16 | execN :: Proxy# n -> (w a -> m a) 17 | 18 | instance Monad w => MonadExecN 'Zero w w where 19 | execN _ = id 20 | 21 | instance (MonadTrans t, Monad (t m), MonadExecN n w m, Monad m) 22 | => MonadExecN ('Suc n) w (t m) 23 | where 24 | execN _ = lift . execN (proxy# :: Proxy# n) 25 | 26 | type MonadExec w m = MonadExecN (Find (EffExec w) m) w m 27 | 28 | -- | Lift an 'IO' action 29 | exec :: forall w m a . MonadExec w m => w a -> m a 30 | exec = execN (proxy# :: Proxy# (Find (EffExec w) m)) 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Roman Cheplyaka 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-10.6 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.10.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | -------------------------------------------------------------------------------- /Control/Monad/Classes.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes 2 | ( -- * State 3 | MonadState 4 | , state 5 | , get 6 | , put 7 | , modify 8 | , modify' 9 | , gets 10 | -- * Reader 11 | , MonadReader 12 | , MonadLocal 13 | , ask 14 | , local 15 | -- * Writer 16 | , MonadWriter 17 | , tell 18 | -- * Exceptions 19 | , MonadExcept 20 | , throw 21 | -- * Exec 22 | , MonadExec 23 | , exec 24 | -- * Core classes and types 25 | -- ** Generic lifting 26 | , MonadLiftN(..) 27 | -- ** Effects 28 | , module Control.Monad.Classes.Effects 29 | -- ** N-classes 30 | , Nat(..) 31 | , MonadStateN(..) 32 | , MonadReaderN(..) 33 | , MonadLocalN(..) 34 | , MonadWriterN(..) 35 | , MonadExceptN(..) 36 | , MonadExecN(..) 37 | -- ** Type families 38 | -- | You should rarely need these. They are exported mostly for 39 | -- documentation and pedagogical purposes. 40 | , Find 41 | , FindTrue 42 | , MapCanDo 43 | , CanDo 44 | ) where 45 | 46 | import Control.Monad.Classes.Effects 47 | import Control.Monad.Classes.Core 48 | import Control.Monad.Classes.State 49 | import Control.Monad.Classes.Reader 50 | import Control.Monad.Classes.Writer 51 | import Control.Monad.Classes.Except 52 | import Control.Monad.Classes.Exec 53 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.stack 21 | 22 | # Ensure necessary system libraries are present 23 | addons: 24 | apt: 25 | packages: 26 | - libgmp-dev 27 | 28 | before_install: 29 | # Download and unpack the stack executable 30 | - mkdir -p ~/.local/bin 31 | - export PATH=$HOME/.local/bin:$PATH 32 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 33 | 34 | install: 35 | # Build dependencies 36 | - stack --no-terminal --install-ghc test --only-dependencies 37 | 38 | script: 39 | # Build the package, its tests, and its docs and run the tests 40 | - stack --no-terminal test --haddock --no-haddock-deps 41 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Run.hs: -------------------------------------------------------------------------------- 1 | -- | Functions to run outer layers of monadic stacks. 2 | -- 3 | -- These are provided for convenience only; you can use the running 4 | -- functions (like 'SL.runState') from the transformers' modules directly. 5 | -- 6 | -- Note that reader and state runners have their arguments swapped around; 7 | -- this makes it convenient to chain them. 8 | module Control.Monad.Classes.Run 9 | ( -- * Identity 10 | run 11 | -- * Reader 12 | , runReader 13 | -- * State 14 | , runStateLazy 15 | , runStateStrict 16 | , evalStateLazy 17 | , evalStateStrict 18 | , execStateLazy 19 | , execStateStrict 20 | -- * Writer 21 | , runWriterLazy 22 | , runWriterStrict 23 | , evalWriterLazy 24 | , evalWriterStrict 25 | , execWriterLazy 26 | , execWriterStrict 27 | , evalWriterWith 28 | , mapWriter 29 | , CustomWriterT'(..) 30 | , CustomWriterT 31 | -- * Except 32 | , runExcept 33 | , runMaybe 34 | -- * Zoom 35 | , runZoom 36 | , ZoomT(..) 37 | -- * ReadState 38 | , ReadStateT(..) 39 | , runReadState 40 | ) where 41 | 42 | import Data.Functor.Identity 43 | import Control.Monad.Classes.Zoom 44 | import Control.Monad.Classes.State 45 | import Control.Monad.Classes.Writer 46 | import Control.Monad.Classes.Reader 47 | import Control.Monad.Classes.Except 48 | import Control.Monad.Classes.ReadState 49 | 50 | run :: Identity a -> a 51 | run = runIdentity 52 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Except.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.Except where 2 | import qualified Control.Monad.Trans.Except as Exc 3 | import qualified Control.Monad.Trans.Maybe as Mb 4 | import qualified Control.Exception as E 5 | import Control.Monad 6 | import Control.Monad.Trans.Class 7 | import GHC.Prim (Proxy#, proxy#) 8 | import Control.Monad.Classes.Core 9 | import Control.Monad.Classes.Effects 10 | 11 | type instance CanDo IO (EffExcept e) = 'True 12 | 13 | type instance CanDo (Exc.ExceptT e m) eff = ExceptCanDo e eff 14 | 15 | type instance CanDo (Mb.MaybeT m) eff = ExceptCanDo () eff 16 | 17 | type family ExceptCanDo e eff where 18 | ExceptCanDo e (EffExcept e) = 'True 19 | ExceptCanDo e eff = 'False 20 | 21 | class Monad m => MonadExceptN (n :: Nat) e m where 22 | throwN :: Proxy# n -> (e -> m a) 23 | 24 | instance Monad m => MonadExceptN 'Zero e (Exc.ExceptT e m) where 25 | throwN _ = Exc.throwE 26 | 27 | instance E.Exception e => MonadExceptN 'Zero e IO where 28 | throwN _ = E.throwIO 29 | 30 | instance Monad m => MonadExceptN 'Zero () (Mb.MaybeT m) where 31 | throwN _ _ = mzero 32 | 33 | instance (MonadTrans t, Monad (t m), MonadExceptN n e m, Monad m) 34 | => MonadExceptN ('Suc n) e (t m) 35 | where 36 | throwN _ = lift . throwN (proxy# :: Proxy# n) 37 | 38 | -- | The @'MonadExcept' e m@ constraint asserts that @m@ is a monad stack 39 | -- that supports throwing exceptions of type @e@ 40 | type MonadExcept e m = MonadExceptN (Find (EffExcept e) m) e m 41 | 42 | -- | Throw an exception 43 | throw :: forall a e m . MonadExcept e m => e -> m a 44 | throw = throwN (proxy# :: Proxy# (Find (EffExcept e) m)) 45 | 46 | runExcept :: Exc.ExceptT e m a -> m (Either e a) 47 | runExcept = Exc.runExceptT 48 | 49 | runMaybe :: Mb.MaybeT m a -> m (Maybe a) 50 | runMaybe = Mb.runMaybeT 51 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Control.Monad.Classes.Core where 3 | 4 | import GHC.Prim (Proxy#, proxy#) 5 | import Control.Monad.Trans.Class 6 | 7 | -- | Peano naturals; used at the type level to denote how far a 8 | -- computation should be lifted 9 | data Nat = Zero | Suc Nat 10 | 11 | -- | @'CanDo' m eff@ describes whether the given effect can be performed in the 12 | -- monad @m@ (without any additional lifting) 13 | type family CanDo (m :: (* -> *)) (eff :: k) :: Bool 14 | 15 | -- | @'MapCanDo' eff stack@ maps the type-level function @(\m -> 'CanDo' 16 | -- m eff)@ over all layers that a monad transformer stack @stack@ consists of 17 | type family MapCanDo (eff :: k) (stack :: * -> *) :: [Bool] where 18 | MapCanDo eff (t m) = (CanDo (t m) eff) ': MapCanDo eff m 19 | MapCanDo eff m = '[ CanDo m eff ] 20 | 21 | -- | @'FindTrue' bs@ returns a (type-level) index of the first occurrence 22 | -- of 'True' in a list of booleans 23 | type family FindTrue 24 | (bs :: [Bool]) -- results of calling Contains 25 | :: Nat 26 | where 27 | FindTrue ('True ': t) = 'Zero 28 | FindTrue ('False ': t) = 'Suc (FindTrue t) 29 | 30 | -- | @'Find' eff m@ finds the first transformer in a monad transformer 31 | -- stack that can handle the effect @eff@ 32 | type Find eff (m :: * -> *) = 33 | FindTrue (MapCanDo eff m) 34 | 35 | class MonadLiftN (n :: Nat) m 36 | where 37 | type Down n m :: * -> * 38 | liftN :: Proxy# n -> Down n m a -> m a 39 | 40 | instance MonadLiftN 'Zero m 41 | where 42 | type Down 'Zero m = m 43 | liftN _ = id 44 | 45 | instance 46 | ( MonadLiftN n m 47 | , MonadTrans t 48 | , Monad m 49 | ) => MonadLiftN ('Suc n) (t m) 50 | where 51 | type Down ('Suc n) (t m) = Down n m 52 | liftN _ = lift . liftN (proxy# :: Proxy# n) 53 | -------------------------------------------------------------------------------- /Control/Monad/Classes/ReadState.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.ReadState where 2 | 3 | import Control.Monad.Classes.Core 4 | import Control.Monad.Classes.Effects 5 | import Control.Monad.Classes.Reader 6 | import Control.Monad.Classes.State 7 | import Control.Monad.Trans.Identity 8 | import Control.Monad.Trans.Class 9 | import Control.Monad.Base 10 | import Control.Monad.Trans.Control 11 | import Data.Proxy 12 | 13 | -- | 'ReadState' is used to translate reader effects into state effects. 14 | -- 15 | -- If you run a computation with 'StateT', this handler is not needed, 16 | -- since 'StateT' already handles read requests. 17 | -- 18 | -- This is useful in cases when you work in an abstract 'MonadState' monad 19 | -- and thus have no guarantee that its handler will also accept reader 20 | -- requests. 21 | newtype ReadStateT s m a = ReadStateT (IdentityT m a) 22 | deriving (Functor, Applicative, Monad, MonadTrans) 23 | 24 | runReadState :: Proxy s -> ReadStateT s m a -> m a 25 | runReadState _ (ReadStateT (IdentityT a)) = a 26 | 27 | type instance CanDo (ReadStateT s m) eff = ReadStateCanDo s eff 28 | 29 | type family ReadStateCanDo s eff where 30 | ReadStateCanDo s (EffReader s) = 'True 31 | ReadStateCanDo s eff = 'False 32 | 33 | instance MonadState s m => MonadReaderN 'Zero s (ReadStateT s m) where 34 | askN _ = ReadStateT (IdentityT get) 35 | 36 | instance MonadBase b m => MonadBase b (ReadStateT x m) where 37 | liftBase = lift . liftBase 38 | 39 | instance MonadTransControl (ReadStateT x) where 40 | type StT (ReadStateT x) a = StT IdentityT a 41 | liftWith = defaultLiftWith ReadStateT (\(ReadStateT a) -> a) 42 | restoreT = defaultRestoreT ReadStateT 43 | 44 | instance MonadBaseControl b m => MonadBaseControl b (ReadStateT s m) where 45 | type StM (ReadStateT s m) a = StM m a 46 | liftBaseWith = defaultLiftBaseWith 47 | restoreM = defaultRestoreM 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/feuerbach/monad-classes.svg?branch=master)](https://travis-ci.org/feuerbach/monad-classes) 2 | 3 | See [this series of articles][1] for the detailed description and motivation. 4 | 5 | [1]: https://ro-che.info/articles/extensible-effects 6 | 7 | This is a more flexible version of mtl, the monad transformers library. 8 | 9 | * You can have many layers of e.g. state transformers in your stack, and 10 | you don't have to explicitly lift your `get`s and `put`s, as soon as 11 | different state transformers carry different types of states. 12 | 13 | Example: 14 | 15 | ``` haskell 16 | a :: (MonadState Bool m, MonadState Int m) => m () 17 | a = do 18 | put False -- set the boolean state 19 | modify (+ (1 :: Int)) -- modify the integer state 20 | ``` 21 | 22 | * mtl requires *Θ(n2)* instances (like `MonadReader e (StateT s m)`); 23 | monad-classes requires only *Θ(n)* of them (where *n* is the number of 24 | different transformer types). 25 | 26 | If you'd like to define your own monad-classes-style class, you have to 27 | write much less boilerplate code. 28 | 29 | ## The status of this repo 30 | 31 | This repo serves two purposes: 32 | 33 | * as a reference implementation accompanying the [series of articles on 34 | extensible effects][1] 35 | * as an actual implementation we use at [Signal Vine](http://signalvine.com/) 36 | 37 | While this is technically open source software, I am not interested in maintaining this as 38 | an active open project. In practice this means that: 39 | 40 | * this version of monad-classes is not on hackage 41 | * I do not accept feature requests and pull requests. The exception is outright 42 | bugs; if you find any, please do report them. 43 | 44 | There is a [hackage package][2] and a [repo][3] maintained by M Farkas-Dyck. 45 | 46 | [2]: https://hackage.haskell.org/package/monad-classes 47 | [3]: https://github.com/strake/monad-classes.hs 48 | -------------------------------------------------------------------------------- /monad-classes.cabal: -------------------------------------------------------------------------------- 1 | name: monad-classes 2 | version: 0.2.2.1 3 | synopsis: more flexible mtl 4 | -- description: 5 | homepage: https://github.com/feuerbach/monad-classes 6 | license: MIT 7 | license-file: LICENSE 8 | author: Roman Cheplyaka 9 | maintainer: Roman Cheplyaka 10 | -- copyright: 11 | category: Control 12 | build-type: Simple 13 | extra-source-files: 14 | README.md 15 | cabal-version: >=1.10 16 | 17 | library 18 | exposed-modules: 19 | Control.Monad.Classes 20 | Control.Monad.Classes.Run 21 | Control.Monad.Classes.Proxied 22 | other-modules: 23 | Control.Monad.Classes.State, 24 | Control.Monad.Classes.Writer, 25 | Control.Monad.Classes.Reader, 26 | Control.Monad.Classes.Except, 27 | Control.Monad.Classes.Exec, 28 | Control.Monad.Classes.Zoom, 29 | Control.Monad.Classes.Core, 30 | Control.Monad.Classes.Effects, 31 | Control.Monad.Classes.ReadState 32 | build-depends: 33 | base >=4.7, 34 | mmorph >= 1.0.3, 35 | transformers >=0.2, 36 | transformers-compat >= 0.3.1, 37 | transformers-base >= 0.4.2, 38 | monad-control >= 1, 39 | reflection >= 1.4, 40 | ghc-prim 41 | -- hs-source-dirs: 42 | default-language: Haskell2010 43 | default-extensions: 44 | TypeFamilies, 45 | DataKinds, 46 | KindSignatures, 47 | FlexibleInstances, 48 | ScopedTypeVariables, 49 | FlexibleContexts, 50 | PolyKinds, 51 | ConstraintKinds, 52 | MultiParamTypeClasses, 53 | TypeOperators, 54 | UndecidableInstances, 55 | MagicHash, 56 | GeneralizedNewtypeDeriving, 57 | RankNTypes 58 | ghc-options: -Wall 59 | 60 | Test-suite test 61 | Default-language: 62 | Haskell2010 63 | Type: 64 | exitcode-stdio-1.0 65 | Hs-source-dirs: 66 | tests 67 | Main-is: 68 | test.hs 69 | Build-depends: 70 | base >= 4 && < 5 71 | , tasty >= 0.8 72 | , tasty-hunit 73 | , monad-classes 74 | , transformers 75 | , data-lens-light >= 0.1.2 76 | , ghc-prim 77 | , conduit 78 | , mmorph 79 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Proxied.hs: -------------------------------------------------------------------------------- 1 | -- | 'Proxied' monad. @'Proxied' x@ is a monad transformer that has a global 2 | -- configuration parameter of type @x@ associated with it. 3 | -- 4 | -- It is used to implement things like @ZoomT@\/@runZoom@ and 5 | -- @CustromWriterT@\/@evalWriterWith@. 6 | -- 7 | -- Most of the time you don't need to use this directly. It is exported for two purposes: 8 | -- 9 | -- * you can use it to define new monad transformers 10 | -- 11 | -- * you can define instances for @'Proxied' x@ and transformers that are 12 | -- based on it 13 | module Control.Monad.Classes.Proxied 14 | ( module Control.Monad.Classes.Proxied 15 | , R.Reifies 16 | , Proxy# 17 | , proxy# 18 | ) 19 | where 20 | 21 | import Control.Applicative 22 | import Control.Monad 23 | import Control.Monad.Base 24 | import Control.Monad.IO.Class 25 | import Control.Monad.Trans.Control 26 | import Control.Monad.Trans.Class 27 | import GHC.Prim (Proxy#, proxy#) 28 | import qualified Data.Reflection as R 29 | import Data.Proxy 30 | 31 | newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a) 32 | 33 | instance Functor m => Functor (Proxied x m) where 34 | fmap f (Proxied g) = Proxied (\px -> fmap f (g px)) 35 | 36 | instance Applicative m => Applicative (Proxied x m) where 37 | pure x = Proxied (\_ -> pure x) 38 | Proxied a <*> Proxied b = Proxied (\px -> a px <*> b px) 39 | 40 | instance Monad m => Monad (Proxied x m) where 41 | return x = Proxied (\_ -> return x) 42 | Proxied a >>= k = Proxied $ \px -> 43 | a px >>= \v -> 44 | case k v of 45 | Proxied b -> b px 46 | 47 | instance Alternative m => Alternative (Proxied x m) where 48 | empty = Proxied $ \_ -> empty 49 | Proxied a <|> Proxied b = Proxied (\px -> a px <|> b px) 50 | 51 | instance MonadPlus m => MonadPlus (Proxied x m) where 52 | mzero = Proxied $ \_ -> mzero 53 | Proxied a `mplus` Proxied b = Proxied (\px -> a px `mplus` b px) 54 | 55 | instance MonadTrans (Proxied x) where 56 | lift a = Proxied $ \_ -> a 57 | 58 | instance MonadIO m => MonadIO (Proxied x m) where 59 | liftIO = lift . liftIO 60 | 61 | instance MonadBase b m => MonadBase b (Proxied x m) where 62 | liftBase = liftBaseDefault 63 | 64 | instance MonadTransControl (Proxied x) where 65 | type StT (Proxied x) a = a 66 | liftWith f = Proxied $ \px -> f $ \(Proxied a) -> a px 67 | restoreT a = Proxied $ \_ -> a 68 | 69 | fromProxy# :: Proxy# a -> Proxy a 70 | fromProxy# _ = Proxy 71 | 72 | toProxy# :: Proxy a -> Proxy# a 73 | toProxy# _ = proxy# 74 | 75 | reify :: a -> (forall (q :: *). R.Reifies q a => Proxy# q -> r) -> r 76 | reify a k = R.reify a $ \px -> k (toProxy# px) 77 | 78 | reflect :: R.Reifies q a => Proxy# q -> a 79 | reflect px = R.reflect (fromProxy# px) 80 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Zoom.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.Zoom where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import Control.Monad.Trans.Class 6 | import Control.Monad.Base 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Trans.Control 9 | import Control.Monad.Classes.Core 10 | import Control.Monad.Classes.Effects 11 | import Control.Monad.Classes.Reader 12 | import Control.Monad.Classes.State 13 | import Control.Monad.Classes.Writer 14 | import Control.Monad.Classes.Proxied 15 | import Data.Functor.Identity 16 | import Data.Monoid 17 | 18 | newtype ZoomT big small m a = ZoomT (Proxied (VLLens big small) m a) 19 | deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadTrans, MonadBase b, MonadIO) 20 | 21 | newtype VLLens big small = VLLens (forall f . Functor f => (small -> f small) -> big -> f big) 22 | 23 | vlGet :: VLLens b a -> b -> a 24 | vlGet (VLLens l) s = getConst (l Const s) 25 | 26 | vlSet :: VLLens b a -> a -> b -> b 27 | vlSet (VLLens l) v s = runIdentity (l (\_ -> Identity v) s) 28 | 29 | -- N.B. applies function eagerly 30 | vlMod' :: VLLens b a -> (a -> a) -> b -> b 31 | vlMod' (VLLens l) f s = runIdentity (l (\x -> Identity $! f x) s) 32 | 33 | runZoom 34 | :: forall big small m a . 35 | (forall f. Functor f => (small -> f small) -> big -> f big) 36 | -> ZoomT big small m a 37 | -> m a 38 | runZoom l a = 39 | reify (VLLens l) $ \px -> 40 | case a of ZoomT (Proxied f) -> f px 41 | 42 | type instance CanDo (ZoomT big small m) eff = ZoomCanDo small eff 43 | 44 | type family ZoomCanDo s eff where 45 | ZoomCanDo s (EffState s) = 'True 46 | ZoomCanDo s (EffReader s) = 'True 47 | ZoomCanDo s (EffWriter s) = 'True 48 | ZoomCanDo s eff = 'False 49 | 50 | instance MonadReader big m => MonadReaderN 'Zero small (ZoomT big small m) 51 | where 52 | askN _ = ZoomT $ Proxied $ \px -> vlGet (reflect px) `liftM` ask 53 | 54 | instance MonadState big m => MonadStateN 'Zero small (ZoomT big small m) 55 | where 56 | stateN _ f = ZoomT $ Proxied $ \px -> 57 | let l = reflect px in 58 | state $ \s -> 59 | case f (vlGet l s) of 60 | (a, t') -> (a, vlSet l t' s) 61 | 62 | instance (MonadState big m, Monoid small) => MonadWriterN 'Zero small (ZoomT big small m) 63 | where 64 | tellN _ w = ZoomT $ Proxied $ \px -> 65 | let l = reflect px in 66 | state $ \s -> 67 | let s' = vlMod' l (<> w) s 68 | in s' `seq` ((), s') 69 | 70 | instance MonadTransControl (ZoomT big small) where 71 | type StT (ZoomT big small) a = a 72 | liftWith = defaultLiftWith ZoomT (\(ZoomT a) -> a) 73 | restoreT = defaultRestoreT ZoomT 74 | 75 | instance MonadBaseControl b m => MonadBaseControl b (ZoomT big small m) where 76 | type StM (ZoomT big small m) a = StM m a 77 | liftBaseWith = defaultLiftBaseWith 78 | restoreM = defaultRestoreM 79 | -------------------------------------------------------------------------------- /Control/Monad/Classes/State.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.State where 2 | import qualified Control.Monad.Trans.State.Lazy as SL 3 | import qualified Control.Monad.Trans.State.Strict as SS 4 | import Control.Monad.Trans.Class 5 | import GHC.Prim (Proxy#, proxy#) 6 | import Control.Monad.Classes.Core 7 | import Control.Monad.Classes.Effects 8 | 9 | type instance CanDo (SS.StateT s m) eff = StateCanDo s eff 10 | type instance CanDo (SL.StateT s m) eff = StateCanDo s eff 11 | 12 | type family StateCanDo s eff where 13 | StateCanDo s (EffState s) = 'True 14 | StateCanDo s (EffReader s) = 'True 15 | StateCanDo s (EffLocal s) = 'True 16 | StateCanDo s (EffWriter s) = 'True 17 | StateCanDo s eff = 'False 18 | 19 | class Monad m => MonadStateN (n :: Nat) s m where 20 | stateN :: Proxy# n -> ((s -> (a, s)) -> m a) 21 | 22 | instance Monad m => MonadStateN 'Zero s (SL.StateT s m) where 23 | stateN _ = SL.state 24 | 25 | instance Monad m => MonadStateN 'Zero s (SS.StateT s m) where 26 | stateN _ = SS.state 27 | 28 | instance (Monad (t m), MonadTrans t, MonadStateN n s m, Monad m) 29 | => MonadStateN ('Suc n) s (t m) 30 | where 31 | stateN _ = lift . stateN (proxy# :: Proxy# n) 32 | 33 | -- | The @'MonadState' s m@ constraint asserts that @m@ is a monad stack 34 | -- that supports state operations on type @s@ 35 | type MonadState s m = MonadStateN (Find (EffState s) m) s m 36 | 37 | -- | Construct a state monad computation from a function 38 | state :: forall s m a. (MonadState s m) => (s -> (a, s)) -> m a 39 | state = stateN (proxy# :: Proxy# (Find (EffState s) m)) 40 | 41 | -- | @'put' s@ sets the state within the monad to @s@ 42 | put :: MonadState s m => s -> m () 43 | put s = state $ \_ -> ((), s) 44 | 45 | -- | Fetch the current value of the state within the monad 46 | get :: MonadState a m => m a 47 | get = state $ \s -> (s, s) 48 | 49 | -- | Gets specific component of the state, using a projection function 50 | -- supplied. 51 | gets :: MonadState s m => (s -> a) -> m a 52 | gets f = do 53 | s <- get 54 | return (f s) 55 | 56 | -- | Maps an old state to a new state inside a state monad layer 57 | modify :: MonadState s m => (s -> s) -> m () 58 | modify f = state (\s -> ((), f s)) 59 | 60 | -- | A variant of 'modify' in which the computation is strict in the 61 | -- new state 62 | modify' :: MonadState s m => (s -> s) -> m () 63 | modify' f = state (\s -> let s' = f s in s' `seq` ((), s')) 64 | 65 | runStateLazy :: s -> SL.StateT s m a -> m (a, s) 66 | runStateLazy = flip SL.runStateT 67 | runStateStrict :: s -> SS.StateT s m a -> m (a, s) 68 | runStateStrict = flip SS.runStateT 69 | 70 | evalStateLazy :: Monad m => s -> SL.StateT s m a -> m a 71 | evalStateLazy = flip SL.evalStateT 72 | evalStateStrict :: Monad m => s -> SS.StateT s m a -> m a 73 | evalStateStrict = flip SS.evalStateT 74 | 75 | execStateLazy :: Monad m => s -> SL.StateT s m a -> m s 76 | execStateLazy = flip SL.execStateT 77 | execStateStrict :: Monad m => s -> SS.StateT s m a -> m s 78 | execStateStrict = flip SS.execStateT 79 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Reader.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.Reader where 2 | import qualified Control.Monad.Trans.Reader as R 3 | import qualified Control.Monad.Trans.State.Lazy as SL 4 | import qualified Control.Monad.Trans.State.Strict as SS 5 | import Control.Monad.Morph (MFunctor, hoist) 6 | import Control.Monad.Trans.Class 7 | import GHC.Prim (Proxy#, proxy#) 8 | import Control.Monad.Classes.Core 9 | import Control.Monad.Classes.Effects 10 | 11 | type instance CanDo (R.ReaderT e m) eff = ReaderCanDo e eff 12 | 13 | type family ReaderCanDo e eff where 14 | ReaderCanDo e (EffReader e) = 'True 15 | ReaderCanDo e (EffLocal e) = 'True 16 | ReaderCanDo e eff = 'False 17 | 18 | class Monad m => MonadReaderN (n :: Nat) r m where 19 | askN :: Proxy# n -> m r 20 | 21 | instance Monad m => MonadReaderN 'Zero r (R.ReaderT r m) where 22 | askN _ = R.ask 23 | 24 | instance Monad m => MonadReaderN 'Zero r (SL.StateT r m) where 25 | askN _ = SL.get 26 | 27 | instance Monad m => MonadReaderN 'Zero r (SS.StateT r m) where 28 | askN _ = SS.get 29 | 30 | instance (MonadTrans t, Monad (t m), MonadReaderN n r m, Monad m) 31 | => MonadReaderN ('Suc n) r (t m) 32 | where 33 | askN _ = lift $ askN (proxy# :: Proxy# n) 34 | 35 | class Monad m => MonadLocalN (n :: Nat) r m where 36 | localN :: Proxy# n -> ((r -> r) -> m a -> m a) 37 | 38 | instance Monad m => MonadLocalN 'Zero r (R.ReaderT r m) where 39 | localN _ = R.local 40 | 41 | stateLocal :: Monad m => (a -> m ()) -> m a -> (a -> a) -> m b -> m b 42 | stateLocal putFn getFn f a = do 43 | s <- getFn 44 | putFn (f s) 45 | r <- a 46 | putFn s 47 | return r 48 | 49 | instance (Monad m) => MonadLocalN 'Zero r (SL.StateT r m) where 50 | localN _ = stateLocal SL.put SL.get 51 | 52 | instance (Monad m) => MonadLocalN 'Zero r (SS.StateT r m) where 53 | localN _ = stateLocal SS.put SS.get 54 | 55 | instance (Monad (t m), MFunctor t, MonadLocalN n r m, Monad m) 56 | => MonadLocalN ('Suc n) r (t m) 57 | where 58 | localN _ = \f -> hoist (localN (proxy# :: Proxy# n) f) 59 | 60 | -- | The @'MonadReader' r m@ constraint asserts that @m@ is a monad stack 61 | -- that supports a fixed environment of type @r@ 62 | type MonadReader e m = MonadReaderN (Find (EffReader e) m) e m 63 | 64 | -- | The @'MonadLocal' r m@ constraint asserts that @m@ is a monad stack 65 | -- that supports a fixed environment of type @r@ that can be changed 66 | -- externally to the monad 67 | type MonadLocal e m = MonadLocalN (Find (EffLocal e) m) e m 68 | 69 | -- | Fetch the environment passed through the reader monad 70 | ask :: forall m r . MonadReader r m => m r 71 | ask = askN (proxy# :: Proxy# (Find (EffReader r) m)) 72 | 73 | -- | Executes a computation in a modified environment. 74 | local :: forall a m r. MonadLocal r m 75 | => (r -> r) -- ^ The function to modify the environment. 76 | -> m a -- ^ @Reader@ to run in the modified environment. 77 | -> m a 78 | local = localN (proxy# :: Proxy# (Find (EffLocal r) m)) 79 | 80 | runReader :: r -> R.ReaderT r m a -> m a 81 | runReader = flip R.runReaderT 82 | -------------------------------------------------------------------------------- /Control/Monad/Classes/Writer.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Classes.Writer where 2 | import Control.Applicative 3 | import Control.Monad 4 | import qualified Control.Monad.Trans.Writer.Lazy as WL 5 | import qualified Control.Monad.Trans.Writer.Strict as WS 6 | import qualified Control.Monad.Trans.State.Lazy as SL 7 | import qualified Control.Monad.Trans.State.Strict as SS 8 | import Control.Monad.Base 9 | import Control.Monad.Trans.Control 10 | import Control.Monad.Trans.Class 11 | import Control.Monad.IO.Class 12 | import Control.Monad.Classes.Core 13 | import Control.Monad.Classes.Effects 14 | import Control.Monad.Classes.Proxied 15 | import Data.Monoid 16 | 17 | type instance CanDo (WL.WriterT w m) eff = WriterCanDo w eff 18 | type instance CanDo (WS.WriterT w m) eff = WriterCanDo w eff 19 | type instance CanDo (CustomWriterT' w n m) eff = WriterCanDo w eff 20 | 21 | type family WriterCanDo w eff where 22 | WriterCanDo w (EffWriter w) = 'True 23 | WriterCanDo w eff = 'False 24 | 25 | class Monad m => MonadWriterN (n :: Nat) w m where 26 | tellN :: Proxy# n -> (w -> m ()) 27 | 28 | instance (Monad m, Monoid w) => MonadWriterN 'Zero w (WL.WriterT w m) where 29 | tellN _ = WL.tell 30 | 31 | instance (Monad m, Monoid w) => MonadWriterN 'Zero w (WS.WriterT w m) where 32 | tellN _ = WS.tell 33 | 34 | instance (Monad m, Monoid w) => MonadWriterN 'Zero w (SL.StateT w m) where 35 | -- lazy 36 | tellN _ w = SL.modify (<> w) 37 | 38 | instance (Monad m, Monoid w) => MonadWriterN 'Zero w (SS.StateT w m) where 39 | tellN _ w = modify' (<> w) 40 | where 41 | modify' :: (s -> s) -> SS.StateT s m () 42 | modify' f = SS.state (\s -> let s' = f s in s' `seq` ((), s')) 43 | 44 | instance Monad m => MonadWriterN 'Zero w (CustomWriterT' w m m) where 45 | tellN _ w = CustomWriterT $ Proxied $ \px -> reflect px w 46 | 47 | instance (MonadTrans t, Monad (t m), MonadWriterN n w m, Monad m) 48 | => MonadWriterN ('Suc n) w (t m) 49 | where 50 | tellN _ = lift . tellN (proxy# :: Proxy# n) 51 | 52 | -- | The @'MonadWriter' w m@ constraint asserts that @m@ is a monad stack 53 | -- that supports outputting values of type @w@ 54 | type MonadWriter w m = MonadWriterN (Find (EffWriter w) m) w m 55 | 56 | -- | @'tell' w@ is an action that produces the output @w@ 57 | tell :: forall w m . MonadWriter w m => w -> m () 58 | tell = tellN (proxy# :: Proxy# (Find (EffWriter w) m)) 59 | 60 | runWriterStrict :: (Monoid w) => SS.StateT w m a -> m (a, w) 61 | runWriterStrict = flip SS.runStateT mempty 62 | 63 | evalWriterStrict :: (Monad m, Monoid w) => SS.StateT w m a -> m a 64 | evalWriterStrict = flip SS.evalStateT mempty 65 | 66 | execWriterStrict :: (Monad m, Monoid w) => SS.StateT w m a -> m w 67 | execWriterStrict = flip SS.execStateT mempty 68 | 69 | runWriterLazy :: WL.WriterT w m a -> m (a, w) 70 | runWriterLazy = WL.runWriterT 71 | 72 | evalWriterLazy :: (Monad m) => WL.WriterT w m a -> m a 73 | evalWriterLazy = liftM fst . runWriterLazy 74 | 75 | execWriterLazy :: (Monad m) => WL.WriterT w m a -> m w 76 | execWriterLazy = WL.execWriterT 77 | 78 | -- The separation between 'n' and 'm' types is needed to implement 79 | -- the MonadTransControl instance 80 | newtype CustomWriterT' w n m a = CustomWriterT (Proxied (w -> n ()) m a) 81 | deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadBase b, MonadIO) 82 | type CustomWriterT w m = CustomWriterT' w m m 83 | 84 | instance MonadTrans (CustomWriterT' w n) where 85 | lift a = CustomWriterT $ Proxied $ \_ -> a 86 | 87 | instance MonadTransControl (CustomWriterT' w n) where 88 | type StT (CustomWriterT' w n) a = StT (Proxied (w -> n ())) a 89 | liftWith = defaultLiftWith CustomWriterT (\(CustomWriterT a) -> a) 90 | restoreT = defaultRestoreT CustomWriterT 91 | 92 | instance MonadBaseControl b m => MonadBaseControl b (CustomWriterT' w n m) where 93 | type StM (CustomWriterT' w n m) a = ComposeSt (CustomWriterT' w n) m a 94 | liftBaseWith = defaultLiftBaseWith 95 | restoreM = defaultRestoreM 96 | 97 | evalWriterWith 98 | :: forall w m a . (w -> m ()) 99 | -> CustomWriterT w m a 100 | -> m a 101 | evalWriterWith tellFn a = 102 | reify tellFn $ \px -> 103 | case a of 104 | CustomWriterT (Proxied a') -> a' px 105 | 106 | -- | Transform all writer requests with a given function 107 | mapWriter 108 | :: forall w1 w2 m a . MonadWriter w2 m 109 | => (w1 -> w2) 110 | -> CustomWriterT w1 m a 111 | -> m a 112 | mapWriter f a = 113 | evalWriterWith (\w1 -> tell (f w1)) a 114 | -------------------------------------------------------------------------------- /tests/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, NoMonomorphismRestriction, 2 | DataKinds, TypeFamilies, TemplateHaskell, ScopedTypeVariables, 3 | MagicHash, FlexibleContexts #-} 4 | import Test.Tasty 5 | import Test.Tasty.HUnit 6 | import Control.Monad.Trans.Class 7 | import qualified Data.Functor.Identity as I 8 | import qualified Control.Monad.Trans.Reader as R 9 | import qualified Control.Monad.Trans.Writer as W 10 | import Control.Monad.Classes 11 | import Control.Monad.Classes.Run 12 | import Control.Applicative 13 | import Control.Exception hiding (throw) 14 | import Data.Lens.Light 15 | import Data.Proxy 16 | import GHC.Prim (Proxy#, proxy#) 17 | 18 | -- for IO tests 19 | import qualified Foreign.Storable as Foreign 20 | import qualified Foreign.Marshal.Alloc as Foreign 21 | 22 | -- for monad-control tests 23 | import qualified Data.Conduit as C 24 | import Control.Monad.Morph 25 | 26 | -- for zoom tests 27 | data Record = Record 28 | { _listL :: [Int] 29 | , _intL :: Int 30 | } 31 | deriving (Show, Eq) 32 | 33 | makeLens ''Record 34 | 35 | main = defaultMain tests 36 | 37 | tests :: TestTree 38 | tests = testGroup "Tests" 39 | [ simpleStateTests 40 | , twoStatesTests 41 | , liftingTest 42 | , localState 43 | , exceptTests 44 | , execTests 45 | , zoomTests 46 | , liftNTests 47 | , liftConduitTest 48 | , mapWriterTest 49 | , readStateTest 50 | , polymorphicTests 51 | ] 52 | 53 | simpleStateTests = testGroup "Simple State" 54 | [ testCase "get" $ 55 | (run $ runStateLazy (0 :: Int) get) @?= (0 :: Int, 0 :: Int) 56 | , testCase "put" $ 57 | (run $ runStateLazy (0 :: Int) (put (1 :: Int))) @?= ((), 1 :: Int) 58 | , testCase "put-get-put" $ 59 | (run $ runStateLazy (0 :: Int) (put (1 :: Int) *> get <* put (2 :: Int))) @?= (1 :: Int, 2 :: Int) 60 | ] 61 | 62 | twoStatesComp = put 'b' >> put True >> put 'c' 63 | 64 | twoStatesTests = testCase "Two States" $ 65 | (run $ runStateLazy 'a' $ runStateLazy False twoStatesComp) @?= (((), True), 'c') 66 | 67 | newtype Foo m a = Foo { runFoo :: m a } 68 | deriving (Functor, Applicative, Monad) 69 | instance MonadTrans Foo where 70 | lift = Foo 71 | type instance CanDo (Foo m) eff = 'False 72 | 73 | liftingTest = testCase "Lifting through an unknown transformer" $ 74 | (run $ runStateLazy 'a' $ runFoo $ runStateLazy False twoStatesComp) @?= (((), True), 'c') 75 | 76 | localState = testCase "MonadLocal StateT" $ 77 | (run $ evalStateStrict 'a' $ 78 | do 79 | s1 <- get 80 | (s2,s3) <- local (toEnum . (+1) . fromEnum :: Char -> Char) $ do 81 | s2 <- get 82 | put 'x' 83 | s3 <- get 84 | return (s2,s3) 85 | s4 <- get 86 | return [s1,s2,s3,s4]) @?= "abxa" 87 | 88 | exceptTests = testGroup "Except" 89 | [ testCase "Catch before IO" $ do 90 | r <- runExcept $ runStateStrict False $ throw $ ErrorCall "foo" 91 | (r :: Either ErrorCall ((), Bool)) @?= Left (ErrorCall "foo") 92 | , testCase "Let escape to IO" $ do 93 | r <- try $ runExcept $ runStateStrict False $ throw UserInterrupt 94 | (r :: Either AsyncException (Either ErrorCall ((), Bool))) @?= Left UserInterrupt 95 | ] 96 | 97 | execTests = testCase "Exec" $ do 98 | r <- runWriterStrict $ exec $ 99 | Foreign.alloca $ \ptr -> do 100 | Foreign.poke ptr True 101 | Foreign.peek ptr 102 | r @?= (True, ()) 103 | 104 | zoomTests = testCase "Zoom" $ do 105 | ((4, [2,5], 6), Record [2,5,10] 6) @?= 106 | (run $ runStateStrict (Record [2] 4) $ runZoom (vanLaarhoven intL) $ runZoom (vanLaarhoven listL) $ do 107 | (s0 :: Int) <- get 108 | tell [5 :: Int] 109 | (s1 :: [Int]) <- ask 110 | put (6 :: Int) 111 | (s2 :: Int) <- ask 112 | tell [10 :: Int] 113 | return (s0, s1, s2) 114 | ) 115 | 116 | liftNTests = testCase "liftN" $ do 117 | (run $ runReader 'a' $ runReader 'b' $ runReader 'c' $ 118 | liftN (proxy# :: Proxy# ('Suc 'Zero)) R.ask) 119 | @?= 'b' 120 | 121 | 122 | liftConduit 123 | :: forall m n effM eff i o r . 124 | ( n ~ Find eff m 125 | , MonadLiftN n m 126 | , effM ~ Down n m 127 | , Monad effM 128 | ) 129 | => Proxy# eff 130 | -> C.ConduitM i o effM r 131 | -> C.ConduitM i o m r 132 | liftConduit _ = hoist (liftN (proxy# :: Proxy# n)) 133 | 134 | liftConduitTest = testCase "lift conduit" $ 135 | (let 136 | src :: C.Source I.Identity Int 137 | src = C.yield 1 >> C.yield 2 138 | 139 | sink :: C.Sink Int (W.Writer [Int]) () 140 | sink = 141 | C.await >>= 142 | maybe (return ()) (\x -> do lift $ tell [x::Int]; sink) 143 | in 144 | W.execWriter $ hoist (liftN (proxy# :: Proxy# ('Suc 'Zero))) src C.$$ sink 145 | ) @?= [1,2] 146 | {- 147 | 148 | execWriterStrict $ runReader (3 :: Int) $ 149 | liftConduit (proxy# :: Proxy# (EffReader Int)) 150 | (do 151 | x <- ask 152 | liftConduit (C.yield x) 153 | liftConduit (C.yield (x :: Int))) 154 | C.$$ 155 | (proxy# :: Proxy# (EffWriter String)) (do C.awaitForever $ \y -> tell (show (y :: Int) ++ "\n"))) 156 | @?= ""-} 157 | 158 | mapWriterTest = testCase "mapWriter" $ do 159 | run (execWriterStrict $ mapWriter (\(w :: Char) -> [w]) $ do { tell 'a'; tell 'b'; tell 'c' }) @?= "abc" 160 | 161 | readStateTest = testCase "ReadState" $ do 162 | let 163 | a1 :: MonadReader Char m => m Char 164 | a1 = ask 165 | 166 | a2 :: MonadState Char m => m Char 167 | a2 = runReadState (Proxy :: Proxy Char) a1 168 | 169 | run (evalStateStrict 'w' a2) @?= 'w' 170 | 171 | polymorphicTests = testGroup "Polymorphic monadic values" 172 | [ testCase "MonadReader WriterT" $ do 173 | run (runReader 'c' (W.runWriterT polyReader1)) @?= ('c', ()) 174 | , testCase "MonadReader ReaderT" $ do 175 | run (runReader 'c' (runReader False polyReader2)) @?= 'c' 176 | ] 177 | where 178 | polyReader1 :: MonadReader Char m => W.WriterT () m Char 179 | polyReader1 = ask 180 | polyReader2 :: MonadReader Char m => R.ReaderT Bool m Char 181 | polyReader2 = ask 182 | --------------------------------------------------------------------------------