mtl-unleashed 0.3.2 → 0.5
raw patch · 4 files changed
+249/−165 lines, 4 filesdep +transformers
Dependencies added: transformers
Files
- Control/Monad/Readers.hs +100/−85
- Control/Monad/States.hs +116/−50
- Tests/Main.hs +31/−28
- mtl-unleashed.cabal +2/−2
Control/Monad/Readers.hs view
@@ -5,112 +5,127 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module Control.Monad.Readers- ( module Control.Monad.Reader- , magnify'- , MonadReaders(ask, local)- , asks- , view, views, iview, iviews- , preview, previews, ipreview, ipreviews- , review, reviews- , Magnify(magnify)+ ( module Control.Monad.Trans.Reader+ , MonadReaders(askPoly, localPoly)+ , viewPoly ) where -import Control.Lens as Lens hiding (view, iview, views, uses, iviews, preview, previews, ipreview, ipreviews, review, reviews, Magnify)-import Control.Lens.Internal.Zoom (Magnified)-import Control.Monad.Reader hiding (MonadReader(ask, local, reader), asks)-import qualified Control.Monad.Reader as MTL (ask, local)-import Control.Monad.State (mapStateT, StateT)-import Control.Monad.Writer (WriterT, mapWriterT)-import Data.Monoid-import Data.Profunctor.Unsafe-import Data.Tagged+import Control.Lens+--import Control.Monad.Reader+--import Control.Monad.State (mapStateT, StateT)+--import Control.Monad.Writer (mapWriterT, WriterT) --- | Version of MonadReader modified to remove the functional dependency.-class Monad m => MonadReaders r m where- ask :: m r- ask = reader id - local :: (r -> r) -> m a -> m a+import Control.Monad.Trans.Cont as Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.Reader as ReaderT (ask, local, reader)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, ask, local, reader)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, ask, local, reader)+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict - reader :: (r -> a) -> m a- reader f = do- r <- ask+import Control.Monad.Trans.Class (lift)+-- import Control.Monad+-- import Data.Monoid++class Monad m => MonadReaders r m where+ askPoly :: m r+ localPoly :: (r -> r) -> m a -> m a+ -- | Retrieves a function of the current environment.+ readerPoly :: (r -> a) -- ^ The selector function to apply to the environment.+ -> m a+ readerPoly f = do+ r <- askPoly :: m r return (f r) +-- | Modified view function that works if there is a MonadReaders r instance+viewPoly :: forall r m a. MonadReaders r m => Getting a r a -> m a+viewPoly lns = (askPoly :: m r) >>= return . view lns+ instance Monad m => MonadReaders r (ReaderT r m) where- ask = MTL.ask- local = MTL.local+ askPoly = ReaderT.ask+ localPoly = ReaderT.local+ readerPoly = ReaderT.reader -instance (Monad m, MonadReaders r m) => MonadReaders r (StateT s m) where- ask = lift ask- local = mapStateT . local+instance MonadReaders r ((->) r) where+ askPoly = id+ localPoly f m = m . f+ readerPoly = id -instance (Monad m, Monoid w, MonadReaders r m) => MonadReaders r (WriterT w m) where- ask = lift ask- local = mapWriterT . local+instance (Monad m, Monoid w) => MonadReaders r (LazyRWS.RWST r w s m) where+ askPoly = LazyRWS.ask+ localPoly = LazyRWS.local+ readerPoly = LazyRWS.reader +instance (Monad m, Monoid w) => MonadReaders r (StrictRWS.RWST r w s m) where+ askPoly = StrictRWS.ask+ localPoly = StrictRWS.local+ readerPoly = StrictRWS.reader+ {---- Here is how you create a MonadReaders instance for a type that is--- nested inside another MonadReaders instances. You need to declare--- this with the exact parent type (here Bar) or you will get--- overlapping instances.+instance MonadReaders r m => MonadReaders r (StateT s m) where+ askPoly = lift askPoly+ localPoly = mapStateT . localPoly -instance (Monad m, MonadReaders Foo m) => MonadReaders Foo (ReaderT Bar m) where- ask = lift ask- local f action = MTL.ask >>= runReaderT (local f (lift action))+instance (Monoid w, MonadReaders r m) => MonadReaders r (WriterT w m) where+ askPoly = lift askPoly+ localPoly = mapWriterT . localPoly -} --- | Retrieves a function of the current environment.-asks :: MonadReaders r m- => (r -> a) -- ^ The selector function to apply to the environment.- -> m a-asks = reader--view :: MonadReaders s m => Getting a s a -> m a-view l = Control.Monad.Readers.asks (getConst #. l Const)--views :: (Profunctor p, MonadReaders s m) => Optical p (->) (Const r) s s a a -> p a r -> m r-views l f = Control.Monad.Readers.asks (getConst #. l (Const #. f))--iview :: MonadReaders s m => IndexedGetting i (i,a) s a -> m (i,a)-iview l = Control.Monad.Readers.asks (getConst #. l (Indexed $ \i -> Const #. (,) i))--iviews :: MonadReaders s m => IndexedGetting i r s a -> (i -> a -> r) -> m r-iviews l = views l .# Indexed--review :: MonadReaders b m => AReview t b -> m t-review p = asks (runIdentity #. unTagged #. p .# Tagged .# Identity)+-- | Modiifed copies of instances from mtl.+instance MonadReaders r' m => MonadReaders r' (ContT r m) where+ askPoly = lift askPoly+ localPoly = Cont.liftLocal askPoly localPoly+ readerPoly = lift . readerPoly -reviews :: MonadReaders b m => AReview t b -> (t -> r) -> m r-reviews p tr = asks (tr . runIdentity #. unTagged #. p .# Tagged .# Identity)+instance (Error e, MonadReaders r m) => MonadReaders r (ErrorT e m) where+ askPoly = lift askPoly+ localPoly = mapErrorT . localPoly+ readerPoly = lift . readerPoly -instance MonadReaders s (ReifiedGetter s) where- ask = Getter id- {-# INLINE ask #-}- local f m = Getter (to f . runGetter m)- {-# INLINE local #-}+instance MonadReaders r m => MonadReaders r (ExceptT e m) where+ askPoly = lift askPoly+ localPoly = mapExceptT . localPoly+ readerPoly = lift . readerPoly -instance MonadReaders s (ReifiedFold s) where- ask = Fold id- {-# INLINE ask #-}- local f m = Fold (to f . runFold m)- {-# INLINE local #-}+instance MonadReaders r m => MonadReaders r (IdentityT m) where+ askPoly = lift askPoly+ localPoly = mapIdentityT . localPoly+ readerPoly = lift . readerPoly -preview :: MonadReaders s m => Getting (First a) s a -> m (Maybe a)-preview l = asks (getFirst #. foldMapOf l (First #. Just))+instance MonadReaders r m => MonadReaders r (ListT m) where+ askPoly = lift askPoly+ localPoly = mapListT . localPoly+ readerPoly = lift . readerPoly -ipreview :: MonadReaders s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a))-ipreview l = asks (getFirst #. ifoldMapOf l (\i a -> First (Just (i, a))))+instance MonadReaders r m => MonadReaders r (MaybeT m) where+ askPoly = lift askPoly+ localPoly = mapMaybeT . localPoly+ readerPoly = lift . readerPoly -previews :: MonadReaders s m => Getting (First r) s a -> (a -> r) -> m (Maybe r)-previews l f = asks (getFirst . foldMapOf l (First #. Just . f))+instance MonadReaders r m => MonadReaders r (Lazy.StateT s m) where+ askPoly = lift askPoly+ localPoly = Lazy.mapStateT . localPoly+ readerPoly = lift . readerPoly -ipreviews :: MonadReaders s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r)-ipreviews l f = asks (getFirst . ifoldMapOf l (\i -> First #. Just . f i))+instance MonadReaders r m => MonadReaders r (Strict.StateT s m) where+ askPoly = lift askPoly+ localPoly = Strict.mapStateT . localPoly+ readerPoly = lift . readerPoly -class (Magnified m ~ Magnified n, MonadReaders b m, MonadReaders a n) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where- magnify :: LensLike' (Magnified m c) a b -> m c -> n c+instance (Monoid w, MonadReaders r m) => MonadReaders r (Lazy.WriterT w m) where+ askPoly = lift askPoly+ localPoly = Lazy.mapWriterT . localPoly+ readerPoly = lift . readerPoly --- | I don't know why Control.Lens.magnify isn't working for me.-magnify' :: forall r s m b. MonadReaders s m => Getting r s r -> ReaderT r m b -> m b-magnify' lns action = view lns >>= runReaderT action+instance (Monoid w, MonadReaders r m) => MonadReaders r (Strict.WriterT w m) where+ askPoly = lift askPoly+ localPoly = Strict.mapWriterT . localPoly+ readerPoly = lift . readerPoly
Control/Monad/States.hs view
@@ -1,71 +1,137 @@ -- | MonadState without the function dependency @m -> s@. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} module Control.Monad.States- ( module Control.Monad.State- , MonadStates(get, put)- , modify- , modify'- , gets- , Control.Monad.States.use, Control.Monad.States.iuse, Control.Monad.States.uses, Control.Monad.States.iuses+ ( MonadStates(getPoly, putPoly)+ , modifyPoly+ , usePoly+ , overPoly ) where -import qualified Control.Lens as Lens (view, views)-import Control.Lens hiding (view, views, iview, iviews, uses)-import Control.Monad.Readers-import Control.Monad.State hiding (MonadState(get, put, state), modify, modify', gets)-import qualified Control.Monad.State as MTL (get, put)+import Control.Lens as Lens+{-+import Control.Monad.Reader (ReaderT)+import Control.Monad.State import Control.Monad.Writer (WriterT)-import Data.Monoid (Monoid)-import Data.Profunctor.Unsafe ((#.))+-} --- | Copy of 'Control.Monad.State.MonadState' with functional dependency m -> s removed.+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, get, put, state)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, get, put, state)+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT, get, put, state)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, get, put, state)+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict++import Control.Monad.Trans.Class (lift)+import Control.Monad+import Data.Monoid+ class Monad m => MonadStates s m where- get :: m s- get = state (\s -> (s, s))- put :: s -> m ()- put s = state (\_ -> ((), s))- state :: (s -> (a, s)) -> m a- state f = do- s <- get+ -- getPoly :: m s+ -- putPoly :: s -> m ()++ getPoly :: m s+ getPoly = statePoly (\s -> (s, s))++ -- | Replace the state inside the monad.+ putPoly :: s -> m ()+ putPoly s = statePoly (\_ -> ((), s))++ -- | Embed a simple state action into the monad.+ statePoly :: (s -> (a, s)) -> m a+ statePoly f = do+ s <- getPoly let ~(a, s') = f s- put s'+ putPoly s' return a+ {-# MINIMAL statePoly | getPoly, putPoly #-} --- | Copy of 'Control.Monad.State.mondify'-modify :: MonadStates s m => (s -> s) -> m ()-modify f = state (\s -> ((), f s))+instance Monad m => MonadStates s (Strict.StateT s m) where+ getPoly = Strict.get+ putPoly = Strict.put+ statePoly = Strict.state --- | Copy of 'Control.Monad.State.modify''-modify' :: MonadStates s m => (s -> s) -> m ()-modify' f = state (\s -> let s' = f s in s' `seq` ((), s'))+instance Monad m => MonadStates s (Lazy.StateT s m) where+ getPoly = Lazy.get+ putPoly = Lazy.put+ statePoly = Lazy.state --- | Copy of 'Control.Monad.State.gets'-gets :: MonadStates s m => (s -> a) -> m a-gets f = do- s <- get- return (f s)+instance MonadStates s m => MonadStates s (ReaderT r m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly -instance Monad m => MonadStates s (StateT s m) where- get = MTL.get- put = MTL.put+instance (Monoid w, MonadStates s m) => MonadStates s (Lazy.WriterT w m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly -instance (Monad m, MonadStates s m) => MonadStates s (ReaderT r m) where- get = lift get- put s = lift $ put s+instance (Monoid w, MonadStates s m) => MonadStates s (Strict.WriterT w m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly -instance (Monad m, Monoid w, MonadStates s m) => MonadStates s (WriterT w m) where- get = lift get- put = lift . put+-- new+instance (Monad m, Monoid w) => MonadStates s (LazyRWS.RWST r w s m) where+ getPoly = LazyRWS.get+ putPoly = LazyRWS.put+ statePoly = LazyRWS.state -use :: MonadStates s m => Getting a s a -> m a-use l = Control.Monad.States.gets (Lens.view l)+instance (Monad m, Monoid w) => MonadStates s (StrictRWS.RWST r w s m) where+ getPoly = StrictRWS.get+ putPoly = StrictRWS.put+ statePoly = StrictRWS.state -iuse :: MonadStates s m => IndexedGetting i (i,a) s a -> m (i,a)-iuse l = Control.Monad.States.gets (getConst #. l (Indexed $ \i -> Const #. (,) i))+-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition. -uses :: MonadStates s m => LensLike' (Const r) s a -> (a -> r) -> m r-uses l f = Control.Monad.States.gets (Lens.views l f)+instance MonadStates s m => MonadStates s (ContT r m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly -iuses :: MonadStates s m => IndexedGetting i r s a -> (i -> a -> r) -> m r-iuses l f = Control.Monad.States.gets (getConst #. l (Const #. Indexed f))+instance (Error e, MonadStates s m) => MonadStates s (ErrorT e m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly++instance MonadStates s m => MonadStates s (ExceptT e m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly++instance MonadStates s m => MonadStates s (IdentityT m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly++instance MonadStates s m => MonadStates s (ListT m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly++instance MonadStates s m => MonadStates s (MaybeT m) where+ getPoly = lift getPoly+ putPoly = lift . putPoly+ statePoly = lift . statePoly++modifyPoly :: (Monad m, MonadStates s m) => (s -> s) -> m ()+modifyPoly f = getPoly >>= putPoly . f++usePoly :: forall s m a. (Monad m, MonadStates s m) => Getting a s a -> m a+usePoly lns = (getPoly :: m s) >>= return . view lns++-- | Modify part of the s+overPoly :: forall s m a. (Monad m, MonadStates s m) => ASetter s s a a -> (a -> a) -> m ()+overPoly lns f = getPoly >>= putPoly . over lns f
Tests/Main.hs view
@@ -8,10 +8,10 @@ import Control.Applicative import Control.Lens as Lens+import Control.Monad.Reader (ReaderT, runReader, runReaderT) import Control.Monad.Readers as Readers+import Control.Monad.State (evalState, lift) import Control.Monad.States as States-import qualified Control.Monad.Reader as MTL-import qualified Control.Monad.State as MTL import Test.Hspec hiding (runIO) import Test.Hspec.Core.Spec (SpecM) @@ -38,22 +38,22 @@ runR action = runReader action (R (S 2.5 True) (T 5 'x')) +-- Custom instances to direct us through stacked/nested reader monads -+-- how to get an S from an R instance Monad m => MonadReaders S (ReaderT R m) where- ask = {-Readers.magnify-} Readers.magnify' s ask- local f action = ask >>= \(r :: R) -> runReaderT (lift action) (set s (f (Lens.view s r)) r)+ askPoly = Lens.magnify s askPoly+ localPoly f action = askPoly >>= \(r :: R) -> runReaderT (lift action) (set s (f (Lens.view s r)) r) +-- how to get a T from an R instance Monad m => MonadReaders T (ReaderT R m) where- ask = {-Readers.magnify-} Readers.magnify' t ask- local f action = ask >>= \(r :: R) -> runReaderT (lift action) (set t (f (Lens.view t r)) r)+ askPoly = Lens.magnify t askPoly+ localPoly f action = askPoly >>= \(r :: R) -> runReaderT (lift action) (set t (f (Lens.view t r)) r) +-- how to get an S from a T (it doesn't have one, we have+-- to get it from m.) instance MonadReaders S m => MonadReaders S (ReaderT T m) where- ask = lift ask- local f action = MTL.ask >>= MTL.runReaderT (local f (lift action))---- This is where the advantages of MonadReaders start to appear:--- use two different MonadReaders instances for the same monad.-s1t1 :: (Applicative m, Functor m, MonadReaders S m, MonadReaders T m) => m (Float, Int)-s1t1 = (,) <$> Readers.view s1 <*> Readers.view t1+ askPoly = lift askPoly+ localPoly f action = lift (askPoly :: m S) >>= runReaderT (localPoly f (lift action)) tests :: SpecM () () tests = do@@ -61,46 +61,49 @@ 1 `shouldBe` 1 it "Can read a value out of Reader using Lens.view" $ do- runReader (Lens.view t1) (T 3 'x') `shouldBe` 3+ runReader (view t1) (T 3 'x') `shouldBe` 3 - it "Can read a value out of Reader using Readers.view" $ do- runReader (Lens.view t1) (T 3 'x') `shouldBe` 3+ it "Can read a value out of Reader using Readers.viewPoly" $ do+ runReader (viewPoly t1) (T 3 'x') `shouldBe` 3 it "Can read a pure value using Lens.view" $ do Lens.view t1 (T 3 'x') `shouldBe` 3 -#if 0- -- Something that makes this work for Lens is missing. I have a- -- feeling inserting a type signature somewhere would help.- it "Can read a pure value Readers.view" $ do- Readers.view t1 (T 3 'x') `shouldBe` (3 :: Int)-#endif+ it "Can read a pure value Readers.viewPoly" $ do+ Readers.viewPoly t1 (T 3 'x') `shouldBe` (3 :: Int) it "sees T using MonadReaders class and modified lens" $ do- runReader (Readers.view t1) (T 3 'x') `shouldBe` 3+ runReader (viewPoly t1) (T 3 'x') `shouldBe` 3 it "Can use state using Lens" $ do evalState (Lens.use t1) (T 5 'r') `shouldBe` 5 it "Can use state using States" $ do- evalState (States.use t1) (T 3 'x') `shouldBe` 3+ evalState (usePoly t1) (T 3 'x') `shouldBe` 3 #if 0- -- These two won't compile due to functional dependency+ -- These two won't compile due to the functional dependency+ -- this package is designed to circumvent. it "sees T using MonadReader class and lens" $ do runBoth (Lens.view t1) `shouldBe` 5 it "sees S using MonadReader class and lens" $ do runBoth (Lens.view s1) `shouldBe` 2.5 #endif-+ -- These two show how viewPoly wins over view. it "sees T using MonadReaders class and lens" $ do- runBoth (Readers.view t1) `shouldBe` 5+ runBoth (viewPoly t1) `shouldBe` 5 it "sees S using MonadReaders class and lens" $ do- runBoth (Readers.view s1) `shouldBe` 2.5+ runBoth (viewPoly s1) `shouldBe` 2.5 it "Can read two different types out of the same monad" $ do runR s1t1 `shouldBe` (2.5, 5)++-- This is where the advantages of MonadReaders start to appear: use+-- multiple MonadReaders instances in the signature context for the+-- same monad.+s1t1 :: forall m. (Applicative m, Functor m, MonadReaders S m, MonadReaders T m) => m (Float, Int)+s1t1 = (,) <$> viewPoly s1 <*> viewPoly t1 main :: IO () main = hspec $ tests
mtl-unleashed.cabal view
@@ -1,5 +1,5 @@ name: mtl-unleashed-version: 0.3.2+version: 0.5 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -19,7 +19,7 @@ extra type signatures. library- build-depends: base < 5, lens >= 4.13, mtl, contravariant, profunctors, tagged+ build-depends: base < 5, lens >= 4.13, mtl, contravariant, profunctors, tagged, transformers ghc-options: -Wall -O2 exposed-modules: Control.Monad.Readers