request-monad 0.2.0.0 → 0.3.0.0
raw patch · 3 files changed
+23/−124 lines, 3 filesdep +free
Dependencies added: free
Files
- CHANGELOG.md +5/−0
- request-monad.cabal +3/−2
- src/Control/Monad/Request/Lazy.hs +15/−122
CHANGELOG.md view
@@ -1,3 +1,8 @@+# 0.3.0.0++* Use `FreeT` monad to implement `RequestT`+* Change the type of callback given to `requestT` from `r' -> m a` to `r' -> RequestT r r' m a`+ # 0.2.0.0 * Generalize `mapRequestT` and `mapResponseT` so that requests may be performed in middleware
request-monad.cabal view
@@ -1,5 +1,5 @@ name: request-monad-version: 0.2.0.0+version: 0.3.0.0 synopsis: A transformer for generic requests description: An MTL-style monad that can be used to perform requests. Using RequestT@@ -23,7 +23,8 @@ hs-source-dirs: src build-depends: base >=4.7 && <4.8, transformers ==0.4.*,- mtl ==2.2.*+ mtl ==2.2.*,+ free ==4.9 exposed-modules: Control.Monad.Request, Control.Monad.Request.Class, Control.Monad.Request.Lazy
src/Control/Monad/Request/Lazy.hs view
@@ -38,14 +38,8 @@ , mapResponseT ) where -import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class import Control.Monad.Request.Class-import Control.Monad.Trans.Class-import Control.Monad.Error.Class-import Control.Monad.RWS.Class-import Data.Monoid+import Control.Monad.Trans.Free import Data.Functor.Identity --------------------------------------------------------------------------------@@ -60,7 +54,7 @@ request :: r -- ^ The request -> (r' -> a) -- ^ The response callback -> Request r r' a -- ^ The resulting computation-request r g = requestT r (Identity . g)+request r g = requestT r (return . g) -- | Evaluate a @'Request' r r\' a@ action. runRequest :: Request r r' a -- ^ The computation to run@@ -87,143 +81,42 @@ -- | A request monad, parameterized by the request type, @r@, response type, -- @r'@, and inner monad, @m@.-data RequestT r r' m a- = Pure a- | Request r (r' -> RequestT r r' m a)- | Lift (m (RequestT r r' m a))+type RequestT r r' = FreeT (RequestF r r') -- | This function takes a request and monadic response handler to produce a -- @'RequestT' r r\' m a@.-requestT :: Monad m => r -- ^ The request- -> (r' -> m a) -- ^ The response callback- -> RequestT r r' m a -- ^ The resulting computation-requestT r g = Request r (Lift . liftM Pure . g)+requestT :: Monad m => r -- ^ The request+ -> (r' -> RequestT r r' m a) -- ^ The response callback+ -> RequestT r r' m a -- ^ The resulting computation+requestT r g = send r >>= g -- | Given a @'RequestT' r r\' m a@ and a mapping from requests to responses, -- return a monadic computation which produces @a@. runRequestT :: Monad m => RequestT r r' m a -- ^ The computation to run -> (r -> m r') -- ^ The request function -> m a -- ^ The resulting computation-runRequestT m req =- let go (Pure a) = return a- go (Request r g) = req r >>= go . g- go (Lift act) = act >>= go- in go m+runRequestT m f = iterT (\(Request r g) -> f r >>= g) m -- | Turn a computation that requests @x@ into a computation that requests @r@. mapRequestT :: Monad m => (x -> RequestT r r' m r) -- ^ The middleware -> RequestT x r' m a -- ^ The @x@-requester -> RequestT r r' m a -- ^ The @r@-requester-mapRequestT f =- let go (Pure a) = Pure a- go (Request x g) = f x >>= flip Request (go . g)- go (Lift act) = Lift (liftM go act)- in go+mapRequestT f = iterTM (\(Request x g) -> f x >>= send >>= g) -- | Turn a computation that handles @x@ into a computation that handles @r'@. mapResponseT :: Monad m => (r' -> RequestT r r' m x) -- ^ The middleware -> RequestT r x m a -- ^ The @x@-handler -> RequestT r r' m a -- ^ The @r'@-handler-mapResponseT f =- let go (Pure a) = Pure a- go (Request r g) = Request r (go . g <=< f)- go (Lift act) = Lift (liftM go act)- in go------------------------------------------------------------------------------------- Type class instances from base.--instance Alternative m => Alternative (RequestT r r' m) where- empty = Lift empty- (<|>) =- let go (Pure a) _ = Pure a- go (Request r g) x = Request r (flip go x . g)- go (Lift act) x = Lift (fmap (flip go x) act)- in go--instance Applicative m => Applicative (RequestT r r' m) where- pure = Pure- (<*>) =- let go (Pure f) (Pure a) = Pure (f a)- go (Request r g) x = Request r (flip go x . g)- go (Lift act) x = Lift (fmap (flip go x) act)- go x (Request r g) = Request r (go x . g)- go x (Lift act) = Lift (fmap (go x) act)- in go--instance Functor m => Functor (RequestT r r' m) where- fmap f =- let go (Pure a) = Pure (f a)- go (Request r g) = Request r (go . g)- go (Lift act) = Lift (fmap go act)- in go--instance Monad m => Monad (RequestT r r' m) where- return = Pure- fail = Lift . fail- (>>=) m f =- let go (Pure a) = f a- go (Request r g) = Request r (go . g)- go (Lift act) = Lift (liftM go act)- in go m--instance MonadPlus m => MonadPlus (RequestT r r' m) where- mzero = Lift mzero- mplus =- let go (Pure a) _ = Pure a- go (Request r g) x = Request r (flip go x . g)- go (Lift act) x = Lift (liftM (flip go x) act)- in go+mapResponseT f = iterTM (\(Request r g) -> send r >>= f >>= g) -------------------------------------------------------------------------------- -- Type class instances from this library. instance Monad m => MonadRequest r r' (RequestT r r' m) where- send = flip Request Pure------------------------------------------------------------------------------------- Type class instances from transformers.--instance MonadIO m => MonadIO (RequestT r r' m) where- liftIO = lift . liftIO--instance MonadTrans (RequestT r r') where- lift = Lift . liftM Pure------------------------------------------------------------------------------------- Type class instances from mtl.--instance MonadError e m => MonadError e (RequestT r r' m) where- throwError = Lift . throwError- catchError m h =- let go (Pure a) = Pure a- go (Request r g) = Request r (go . g)- go (Lift act) = Lift (catchError act (return . h))- in go m---instance MonadReader x m => MonadReader x (RequestT r r' m) where- ask = lift ask- local f =- let go (Pure a) = Pure a- go (Request r g) = Request r (go . g)- go (Lift act) = Lift (liftM go (local f act))- in go--instance (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (RequestT r r' m)+ send r = liftF (Request r id) -instance MonadState s m => MonadState s (RequestT r r' m) where- get = lift get- put = lift . put+-- This is the base Functor used to construct 'RequestT'.+data RequestF r r' f = Request r (r' -> f) -instance (Monoid w, MonadWriter w m) => MonadWriter w (RequestT r r' m) where- writer = lift . writer- tell = lift . tell- listen =- let go acc (Pure a) = Pure (a, acc)- go acc (Request r g) = Request r (go acc . g)- go acc (Lift act) = Lift $ do- ~(m, w) <- listen act- return (go (acc `mappend` w) m)- in go mempty- pass m = listen m >>= \ ~(~(a, f), w) -> writer (a, f w)+instance Functor (RequestF r r') where+ fmap f (Request r g) = Request r (f . g)