eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

servant-client-ghcjs: Renamed GhcjsClientM to ClientM

Browse source
This commit is contained in:
Falco Peijnenburg 2017-09-26 21:38:44 +02:00
parent 67f2285e30
commit 8d1229f2d4
2 changed files with 23 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
servant-client-ghcjs/src/Servant/Client/Ghcjs.hs
View file

@ -4,9 +4,9 @@
module Servant.Client.Ghcjs module Servant.Client.Ghcjs
( (
client client
, GhcjsClientM , ClientM
, runGhcjsClientM , runClientM
, GhcjsClientEnv(..) , ClientEnv(..)
, module Servant.Client.Core.Reexport , module Servant.Client.Core.Reexport
) where ) where

40
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
View file

@ -44,46 +44,46 @@ newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
newtype GhcjsClientEnv newtype ClientEnv
= GhcjsClientEnv = ClientEnv
{ baseUrl :: BaseUrl } { baseUrl :: BaseUrl }
deriving (Eq, Show) deriving (Eq, Show)
client :: HasClient GhcjsClientM api => Proxy api -> Client GhcjsClientM api client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy GhcjsClientM) client api = api `clientIn` (Proxy :: Proxy ClientM)
newtype GhcjsClientM a = GhcjsClientM newtype ClientM a = ClientM
{ runGhcjsClientM' :: ReaderT GhcjsClientEnv (ExceptT ServantError IO) a } { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader GhcjsClientEnv, MonadError ServantError, MonadThrow , MonadReader ClientEnv, MonadError ServantError, MonadThrow
, MonadCatch) , MonadCatch)
instance MonadBase IO GhcjsClientM where instance MonadBase IO ClientM where
liftBase = GhcjsClientM . liftBase liftBase = ClientM . liftBase
instance MonadBaseControl IO GhcjsClientM where instance MonadBaseControl IO ClientM where
type StM GhcjsClientM a = Either ServantError a type StM ClientM a = Either ServantError a
liftBaseWith f = GhcjsClientM (liftBaseWith (\g -> f (g . runGhcjsClientM'))) liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
restoreM st = GhcjsClientM (restoreM st) restoreM st = ClientM (restoreM st)
-- | Try clients in order, last error is preserved. -- | Try clients in order, last error is preserved.
instance Alt GhcjsClientM where instance Alt ClientM where
a <!> b = a `catchError` const b a <!> b = a `catchError` const b
instance RunClient GhcjsClientM where instance RunClient ClientM where
runRequest = performRequest runRequest = performRequest
throwServantError = throwError throwServantError = throwError
catchServantError = catchError catchServantError = catchError
instance ClientLike (GhcjsClientM a) (GhcjsClientM a) where instance ClientLike (ClientM a) (ClientM a) where
mkClient = id mkClient = id
runGhcjsClientM :: GhcjsClientM a -> GhcjsClientEnv -> IO (Either ServantError a) runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runGhcjsClientM cm env = runExceptT $ flip runReaderT env $ runGhcjsClientM' cm runClientM cm env = runExceptT $ flip runReaderT env $ runClientM' cm
performRequest :: Request -> GhcjsClientM Response performRequest :: Request -> ClientM Response
performRequest req = do performRequest req = do
xhr <- liftIO initXhr xhr <- liftIO initXhr
burl <- asks baseUrl burl <- asks baseUrl
@ -188,7 +188,7 @@ toBody request = case requestBody request of
-- This function is only supposed to handle 'ConnectionError's. Other -- This function is only supposed to handle 'ConnectionError's. Other
-- 'ServantError's are created in Servant.Client.Req. -- 'ServantError's are created in Servant.Client.Req.
toResponse :: JSXMLHttpRequest -> GhcjsClientM Response toResponse :: JSXMLHttpRequest -> ClientM Response
toResponse xhr = do toResponse xhr = do
status <- liftIO $ getStatus xhr status <- liftIO $ getStatus xhr
case status of case status of