~singpolyma/network-protocol-xmpp

761236be0e5a5b9bfbb72b506af658b9fce4de95 — John Millikin 12 years ago fa4477d
Define instances of 'Applicative' and 'MonadFix' for 'XMPP'.
2 files changed, 16 insertions(+), 0 deletions(-)

M Network/Protocol/XMPP/ErrorT.hs
M Network/Protocol/XMPP/Monad.hs
M Network/Protocol/XMPP/ErrorT.hs => Network/Protocol/XMPP/ErrorT.hs +6 -0
@@ 20,6 20,7 @@ module Network.Protocol.XMPP.ErrorT
	) where

import Control.Monad (liftM)
import Control.Monad.Fix (MonadFix, mfix)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Error as E


@@ 60,6 61,11 @@ instance R.MonadReader m => R.MonadReader (ErrorT e m) where
instance MonadIO m => MonadIO (ErrorT e m) where
	liftIO = lift . liftIO

instance MonadFix m => MonadFix (ErrorT e m) where
	mfix f = ErrorT $ mfix $ \ex -> runErrorT $ f $ case ex of
		Right x -> x
		_        -> error "empty mfix parameter"

mapErrorT :: (m (Either e a) -> n (Either e' b))
           -> ErrorT e m a
           -> ErrorT e' n b

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +10 -0
@@ 34,6 34,9 @@ module Network.Protocol.XMPP.Monad
	, putElement
	, putStanza
	) where
import qualified Control.Applicative as A
import Control.Monad (ap)
import Control.Monad.Fix (MonadFix, mfix)
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R


@@ 78,6 81,13 @@ instance E.MonadError XMPP where
	throwError = XMPP . E.throwError
	catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h)

instance A.Applicative XMPP where
	pure = return
	(<*>) = ap

instance MonadFix XMPP where
	mfix f = XMPP $ mfix $ unXMPP . f

runXMPP :: Context -> XMPP a -> IO (Either Error a)
runXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx