diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/request-monad.cabal b/request-monad.cabal --- a/request-monad.cabal +++ b/request-monad.cabal @@ -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 diff --git a/src/Control/Monad/Request/Lazy.hs b/src/Control/Monad/Request/Lazy.hs --- a/src/Control/Monad/Request/Lazy.hs +++ b/src/Control/Monad/Request/Lazy.hs @@ -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)