51e6b97 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

Remove MonadWidget, tighten imports

51e6b97Greg Hale10 years ago

exec/Example.hs+11−2

compare with master

unifiedsplit

@@ -8,7 +8,8 @@ module Main where

9import Data.Bool

10import Data.Maybe

11+import Control.Monad.Fix (MonadFix)

11−import Data.Monoid

12+import Data.Monoid ((<>))

12import Data.Text (Text)

13import Data.Text (Text)

13import qualified Data.Text as T

14import qualified Data.Text as T

14import Servant.API

15import Servant.API

@@ -25,7 +26,12 @@ main :: IO ()

25main = mainWidget run

26main = mainWidget run

28−run :: forall t m. MonadWidget t m => m ()

29+run :: forall t m. (SupportsServantReflex t m,

30+ DomBuilder t m,

31+ DomBuilderSpace m ~ GhcjsDomSpace,

32+ MonadFix m,

33+ PostBuild t m,

34+ MonadHold t m) => m ()

29run = do

35run = do

31 -- Allow user to choose the url target for the request

37 -- Allow user to choose the url target for the request

@@ -110,3 +116,6 @@ showRB (XhrResponseBody_Default t) = tShow t

110showRB (XhrResponseBody_Text t) = tShow t

116showRB (XhrResponseBody_Text t) = tShow t

111showRB (XhrResponseBody_Blob t) = "<Blob>"

117showRB (XhrResponseBody_Blob t) = "<Blob>"

112showRB (XhrResponseBody_ArrayBuffer t) = tShow t

118showRB (XhrResponseBody_ArrayBuffer t) = tShow t

119+

120+note :: e -> Maybe a -> Either e a

121+note e = maybe (Left e) Right

src/Servant/Common/BaseUrl.hs+16−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE ConstraintKinds #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

@@ -13,9 +14,14 @@ module Servant.Common.BaseUrl (

13 -- * functions

14 -- * functions

14 , baseUrlWidget

15 , baseUrlWidget

15 , showBaseUrl

16 , showBaseUrl

17+

18+ -- * constraints

19+ , SupportsServantReflex

16) where

20) where

18import Control.Monad (join)

22import Control.Monad (join)

23+import Control.Monad.IO.Class (MonadIO)

24+import Control.Monad.Fix (MonadFix)

19import Data.Monoid ((<>))

25import Data.Monoid ((<>))

20import Data.Text (Text)

26import Data.Text (Text)

21import qualified Data.Text as T

27import qualified Data.Text as T

@@ -24,6 +30,9 @@ import Reflex

24import Reflex.Dom

30import Reflex.Dom

25import Text.Read

31import Text.Read

33+

34+type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))

35+

27-- | URI scheme to use

36-- | URI scheme to use

28data Scheme =

37data Scheme =

29 Http -- ^ http://

38 Http -- ^ http://

@@ -58,7 +67,13 @@ showBaseUrl (BaseFullUrl urlscheme host port path) =

58 (Https, 443) -> ""

67 (Https, 443) -> ""

59 _ -> ":" <> T.pack (show port)

68 _ -> ":" <> T.pack (show port)

61−baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)

70+baseUrlWidget :: forall t m .(SupportsServantReflex t m,

71+ DomBuilderSpace m ~ GhcjsDomSpace,

72+ MonadFix m,

73+ PostBuild t m,

74+ MonadHold t m,

75+ DomBuilder t m)

76+ => m (Dynamic t BaseUrl)

62baseUrlWidget = elClass "div" "base-url" $ do

77baseUrlWidget = elClass "div" "base-url" $ do

63 urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def

78 urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def

64 let bUrlWidget = ffor (value urlWidget) $ \i -> case i of

79 let bUrlWidget = ffor (value urlWidget) $ \i -> case i of

src/Servant/Common/Req.hs+19−19

@@ -9,20 +9,19 @@

9module Servant.Common.Req where

11-------------------------------------------------------------------------------

12−import Control.Applicative (liftA2, liftA3)

12+import Control.Applicative (liftA2, liftA3)

13import qualified Data.ByteString.Lazy.Char8 as BL

14−import qualified Data.Map as Map

14+import qualified Data.Map as Map

15−import Data.Maybe

15+import Data.Maybe (catMaybes)

16−import Data.Monoid

16+import Data.Monoid ((<>))

17−import Data.Proxy (Proxy(..))

17+import Data.Proxy (Proxy(..))

18−import Data.Text (Text)

18+import Data.Text (Text)

19−import qualified Data.Text as T

19+import qualified Data.Text as T

20−import qualified Data.Text.Encoding as TE

20+import qualified Data.Text.Encoding as TE

21−import Reflex

22import Reflex.Dom

21import Reflex.Dom

23−import Servant.Common.BaseUrl

22+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)

24−import Servant.API.ContentTypes

23+import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

25−import Web.HttpApiData

24+import Web.HttpApiData (ToHttpApiData(..))

26-------------------------------------------------------------------------------

25-------------------------------------------------------------------------------

27import Servant.API.BasicAuth

26import Servant.API.BasicAuth

@@ -90,14 +89,12 @@ displayHttpRequest :: Text -> Text

90displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

89displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

92-- | This function actually performs the request.

91-- | This function actually performs the request.

93−performRequest :: forall t m.MonadWidget t m

92+performRequest :: forall t m.(SupportsServantReflex t m)

94 => Text

93 => Text

95 -> Req t

94 -> Req t

96 -> Dynamic t BaseUrl

95 -> Dynamic t BaseUrl

97 -> Event t ()

96 -> Event t ()

98 -> m (Event t XhrResponse, Event t Text)

97 -> m (Event t XhrResponse, Event t Text)

99− -- -> ExceptT ServantError IO ( Int, ByteString, MediaType

100− -- , [HTTP.Header], Response ByteString)

101performRequest reqMeth req reqHost trigger = do

98performRequest reqMeth req reqHost trigger = do

102

103 let t :: Dynamic t [Either Text Text]

100 let t :: Dynamic t [Either Text Text]

@@ -210,15 +207,18 @@ bytesToPayload :: BL.ByteString -> XhrPayload

210bytesToPayload = T.pack . BL.unpack

207bytesToPayload = T.pack . BL.unpack

211#endif

208#endif

212

209

213−performRequestNoBody ::

210+performRequestNoBody :: forall t m .(SupportsServantReflex t m)

211+ => Text

212+ -> Req t

214− forall t m .MonadWidget t m => Text -> Req t -> Dynamic t BaseUrl

213+ -> Dynamic t BaseUrl

215− -> Event t () -> m (Event t (ReqResult NoContent))

214+ -> Event t () -> m (Event t (ReqResult NoContent))

216performRequestNoBody reqMeth req reqHost trigger = do

215performRequestNoBody reqMeth req reqHost trigger = do

217 (resp, badReq) <- performRequest reqMeth req reqHost trigger

216 (resp, badReq) <- performRequest reqMeth req reqHost trigger

218 return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

217 return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

219

218

220

219

220+performRequestCT :: (SupportsServantReflex t m,

221−performRequestCT :: (MonadWidget t m, MimeUnrender ct a)

221+ MimeUnrender ct a)

222 => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl

223 -> Event t () -> m (Event t (ReqResult a))

224performRequestCT ct reqMeth req reqHost trigger = do

src/Servant/Reflex.hs+40−19

@@ -23,22 +23,43 @@ module Servant.Reflex

23 , module Servant.Common.BaseUrl

24 ) where

26+-------------------------------------------------------------------------------

26import Control.Applicative

27import Control.Applicative

28+import Data.Monoid ((<>))

27import qualified Data.Set as Set

29import qualified Data.Set as Set

28import qualified Data.Text.Encoding as E

30import qualified Data.Text.Encoding as E

29import Data.CaseInsensitive (mk)

31import Data.CaseInsensitive (mk)

30−import Data.Proxy

32+import Data.Proxy (Proxy (..))

31−import Data.String.Conversions

32import qualified Data.Map as Map

33import qualified Data.Map as Map

33import Data.Text (Text)

34import Data.Text (Text)

34import qualified Data.Text as T

35import qualified Data.Text as T

35−import Data.Text.Encoding

36−import GHC.TypeLits

36+import GHC.TypeLits (KnownSymbol, symbolVal)

37−import Servant.API

37+import Servant.API ((:<|>)(..),(:>), BasicAuth,

38+ BasicAuthData, BuildHeadersTo(..),

39+ Capture, contentType, Header,

40+ Headers(..), HttpVersion, IsSecure,

41+ MimeRender(..), MimeUnrender,

42+ NoContent, QueryFlag, QueryParam,

43+ QueryParams, Raw, ReflectMethod(..),

44+ RemoteHost, ReqBody,

45+ ToHttpApiData(..), Vault, Verb)

38−import Servant.Common.BaseUrl

46+import Servant.Common.BaseUrl (BaseUrl, baseUrlWidget, showBaseUrl,

47+ SupportsServantReflex)

39−import Servant.Common.Req

48+import Servant.Common.Req (Req, ReqResult(..), QParam(..),

40−import Reflex

49+ QueryPart(..), addHeader, authData,

50+ defReq, prependToPathParts,

51+ performRequestCT,

52+ performRequestNoBody,

53+ qParamToQueryPart, reqBody,

54+ reqSuccess, reqFailure,

55+ reqMethod, respHeaders, response,

56+ qParams)

41−import Reflex.Dom

57+import Reflex.Dom (Dynamic, Event, Reflex,

58+ XhrRequest(..),

59+ XhrResponseHeaders(..),

60+ XhrResponse(..), ffor, fmapMaybe,

61+ leftmost, performRequestAsync,

62+ tagPromptlyDyn )

43-- * Accessing APIs as a Client

64-- * Accessing APIs as a Client

@@ -78,13 +99,13 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

78-- >

99-- >

79-- > myApi :: Proxy MyApi = Proxy

100-- > myApi :: Proxy MyApi = Proxy

80-- >

101-- >

81−-- > getBook :: MonadWidget t m

102+-- > getBook :: SupportsServantReflex t m

82-- => Dynamic t BaseUrl

103-- => Dynamic t BaseUrl

83-- -> Dynamic t (Maybe Text)

104-- -> Dynamic t (Maybe Text)

84-- -> Event t ()

105-- -> Event t ()

85-- -> m (Event t (Either XhrError (Text, Book)))

106-- -> m (Event t (Either XhrError (Text, Book)))

86-- > getBook = client myApi (constDyn host)

107-- > getBook = client myApi (constDyn host)

87−instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)

108+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

88 => HasClient t m (Capture capture a :> sublayout) where

109 => HasClient t m (Capture capture a :> sublayout) where

110

90 type Client t m (Capture capture a :> sublayout) =

111 type Client t m (Capture capture a :> sublayout) =

@@ -101,7 +122,7 @@ instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)

101-- VERB (Returning content) --

122-- VERB (Returning content) --

102instance {-# OVERLAPPABLE #-}

123instance {-# OVERLAPPABLE #-}

103 -- Note [Non-Empty Content Types]

124 -- Note [Non-Empty Content Types]

104− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m

125+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

105 ) => HasClient t m (Verb method status cts' a) where

126 ) => HasClient t m (Verb method status cts' a) where

106 type Client t m (Verb method status cts' a) =

127 type Client t m (Verb method status cts' a) =

107 Event t () -> m (Event t (ReqResult a))

128 Event t () -> m (Event t (ReqResult a))

@@ -109,12 +130,12 @@ instance {-# OVERLAPPABLE #-}

109 -- ExceptT ServantError IO a

130 -- ExceptT ServantError IO a

110 clientWithRoute Proxy _ req baseurl =

131 clientWithRoute Proxy _ req baseurl =

111 performRequestCT (Proxy :: Proxy ct) method req' baseurl

132 performRequestCT (Proxy :: Proxy ct) method req' baseurl

112− where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

133+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

113 req' = req { reqMethod = method }

134 req' = req { reqMethod = method }

114

135

115-- -- VERB (No content) --

136-- -- VERB (No content) --

116instance {-# OVERLAPPING #-}

137instance {-# OVERLAPPING #-}

117− (ReflectMethod method, MonadWidget t m) =>

138+ (ReflectMethod method, SupportsServantReflex t m) =>

118 HasClient t m (Verb method status cts NoContent) where

139 HasClient t m (Verb method status cts NoContent) where

119 type Client t m (Verb method status cts NoContent) =

140 type Client t m (Verb method status cts NoContent) =

120 Event t () -> m (Event t (ReqResult NoContent))

141 Event t () -> m (Event t (ReqResult NoContent))

@@ -122,7 +143,7 @@ instance {-# OVERLAPPING #-}

122 -- ExceptT ServantError IO NoContent

143 -- ExceptT ServantError IO NoContent

123 clientWithRoute Proxy _ req baseurl =

144 clientWithRoute Proxy _ req baseurl =

124 performRequestNoBody method req baseurl

145 performRequestNoBody method req baseurl

125− where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

146+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

126

147

127toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)

148toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)

128toHeaders r =

149toHeaders r =

@@ -152,7 +173,7 @@ instance {-# OVERLAPPABLE #-}

152 -- Note [Non-Empty Content Types]

173 -- Note [Non-Empty Content Types]

153 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

174 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

154 ReflectMethod method, cts' ~ (ct ': cts),

175 ReflectMethod method, cts' ~ (ct ': cts),

155− MonadWidget t m

176+ SupportsServantReflex t m

156 ) => HasClient t m (Verb method status cts' (Headers ls a)) where

177 ) => HasClient t m (Verb method status cts' (Headers ls a)) where

157 type Client t m (Verb method status cts' (Headers ls a)) =

178 type Client t m (Verb method status cts' (Headers ls a)) =

158 Event t () -> m (Event t (ReqResult (Headers ls a)))

179 Event t () -> m (Event t (ReqResult (Headers ls a)))

@@ -167,7 +188,7 @@ instance {-# OVERLAPPABLE #-}

167-- HEADERS Verb (No content) --

188-- HEADERS Verb (No content) --

168instance {-# OVERLAPPABLE #-}

189instance {-# OVERLAPPABLE #-}

169 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

190 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

170− MonadWidget t m

191+ SupportsServantReflex t m

171 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where

192 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where

172 type Client t m (Verb method status cts (Headers ls NoContent))

193 type Client t m (Verb method status cts (Headers ls NoContent))

173 = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))

194 = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))

@@ -194,7 +215,7 @@ instance {-# OVERLAPPABLE #-}

194-- > -- then you can just use "viewRefer" to query that endpoint

215-- > -- then you can just use "viewRefer" to query that endpoint

195-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

216-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

196instance (KnownSymbol sym, ToHttpApiData a,

217instance (KnownSymbol sym, ToHttpApiData a,

197− HasClient t m sublayout, MonadWidget t m)

218+ HasClient t m sublayout, SupportsServantReflex t m)

198 => HasClient t m (Header sym a :> sublayout) where

219 => HasClient t m (Header sym a :> sublayout) where

199

220

200 type Client t m (Header sym a :> sublayout) =

221 type Client t m (Header sym a :> sublayout) =

@@ -346,7 +367,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

346-- | Pick a 'Method' and specify where the server you want to query is. You get

367-- | Pick a 'Method' and specify where the server you want to query is. You get

347-- back the full `Response`.

368-- back the full `Response`.

348-- TODO redo

369-- TODO redo

349−instance (MonadWidget t m) => HasClient t m Raw where

370+instance SupportsServantReflex t m => HasClient t m Raw where

350 type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))

371 type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))

351 -> Event t ()

372 -> Event t ()

352 -> m (Event t (ReqResult ()))

373 -> m (Event t (ReqResult ()))