rhi/haskell-gnutls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fixups for AMP changes.

Browse source
This commit is contained in:
Michael Alan Dorman 2015-04-25 16:44:46 -04:00 committed by John Millikin
parent 5588ba43c8
commit a8b816730b
2 changed files with 20 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lib/Network/Protocol/TLS/GNU.hs
View file

@ -42,8 +42,9 @@ module Network.Protocol.TLS.GNU
, CertificateType (..) , CertificateType (..)
) where ) where
import Control.Applicative (Applicative, pure, (<*>))
import qualified Control.Concurrent.MVar as M import qualified Control.Concurrent.MVar as M
import Control.Monad (when, foldM, foldM_) import Control.Monad (ap, when, foldM, foldM_)
import qualified Control.Monad.Error as E import qualified Control.Monad.Error as E
import Control.Monad.Error (ErrorType) import Control.Monad.Error (ErrorType)
import qualified Control.Monad.Reader as R import qualified Control.Monad.Reader as R
@ -95,6 +96,10 @@ newtype TLS a = TLS { unTLS :: ErrorT Error (R.ReaderT Session IO) a }
instance Functor TLS where instance Functor TLS where
fmap f = TLS . fmap f . unTLS fmap f = TLS . fmap f . unTLS
instance Applicative TLS where
pure = TLS . return
(<*>) = ap
instance Monad TLS where instance Monad TLS where
return = TLS . return return = TLS . return
m >>= f = TLS $ unTLS m >>= unTLS . f m >>= f = TLS $ unTLS m >>= unTLS . f

15
lib/Network/Protocol/TLS/GNU/ErrorT.hs
View file

@ -20,7 +20,8 @@ module Network.Protocol.TLS.GNU.ErrorT
, mapErrorT , mapErrorT
) where ) where
import Control.Monad (liftM) import Control.Applicative (Applicative, pure, (<*>))
import Control.Monad (ap,liftM)
import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Error as E import qualified Control.Monad.Error as E
@ -35,6 +36,18 @@ newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
instance Functor m => Functor (ErrorT e m) where instance Functor m => Functor (ErrorT e m) where
fmap f = ErrorT . fmap (fmap f) . runErrorT fmap f = ErrorT . fmap (fmap f) . runErrorT
instance (Functor m, Monad m) => Applicative (ErrorT e m) where
pure a = ErrorT $ return (Right a)
f <*> v = ErrorT $ do
mf <- runErrorT f
case mf of
Left e -> return (Left e)
Right k -> do
mv <- runErrorT v
case mv of
Left e -> return (Left e)
Right x -> return (Right (k x))
instance Monad m => Monad (ErrorT e m) where instance Monad m => Monad (ErrorT e m) where
return = ErrorT . return . Right return = ErrorT . return . Right
(>>=) m k = ErrorT $ do (>>=) m k = ErrorT $ do