Remove MonadWidget, tighten imports

2024-09-11 07:15:29 +03:00 · 2016-08-29 22:20:44 -04:00 · 2016-08-29 22:20:44 -04:00 · 51e6b971b0
commit 51e6b971b0
parent da0bd01e5e
4 changed files with 86 additions and 41 deletions
--- a/exec/Example.hs
+++ b/exec/Example.hs
@ -8,7 +8,8 @@ module Main where

 import Data.Bool
 import Data.Maybe
-import Data.Monoid
+import Control.Monad.Fix (MonadFix)
+import Data.Monoid ((<>))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Servant.API
@ -25,7 +26,12 @@ main :: IO ()
 main = mainWidget run


-run :: forall t m. MonadWidget t m => m ()
+run :: forall t m. (SupportsServantReflex t m,
+                    DomBuilder t m,
+                    DomBuilderSpace m ~ GhcjsDomSpace,
+                    MonadFix m,
+                    PostBuild t m,
+                    MonadHold t m) => m ()
 run = do

  -- Allow user to choose the url target for the request
@ -110,3 +116,6 @@ showRB (XhrResponseBody_Default t) = tShow t
 showRB (XhrResponseBody_Text t) = tShow t
 showRB (XhrResponseBody_Blob t) = "<Blob>"
 showRB (XhrResponseBody_ArrayBuffer t) = tShow t
+
+note :: e -> Maybe a -> Either e a
+note e = maybe (Left e) Right
--- a/src/Servant/Common/BaseUrl.hs
+++ b/src/Servant/Common/BaseUrl.hs
@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds     #-}
 {-# LANGUAGE DeriveDataTypeable  #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
@ -13,9 +14,14 @@ module Servant.Common.BaseUrl (
  -- * functions
  , baseUrlWidget
  , showBaseUrl
+
+  -- * constraints
+  , SupportsServantReflex
 ) where

 import           Control.Monad (join)
+import           Control.Monad.IO.Class (MonadIO)
+import           Control.Monad.Fix (MonadFix)
 import           Data.Monoid ((<>))
 import           Data.Text (Text)
 import qualified Data.Text as T
@ -24,6 +30,9 @@ import           Reflex
 import           Reflex.Dom
 import           Text.Read

+
+type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))
+
 -- | URI scheme to use
 data Scheme =
    Http  -- ^ http://
@ -58,7 +67,13 @@ showBaseUrl (BaseFullUrl urlscheme host port path) =
        (Https, 443) -> ""
        _ -> ":" <> T.pack (show port)

-baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)
+baseUrlWidget :: forall t m .(SupportsServantReflex t m,
+                              DomBuilderSpace m ~ GhcjsDomSpace,
+                              MonadFix m,
+                              PostBuild t m,
+                              MonadHold t m,
+                              DomBuilder t m)
+              => m (Dynamic t BaseUrl)
 baseUrlWidget = elClass "div" "base-url" $ do
  urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def
  let bUrlWidget = ffor (value urlWidget) $ \i -> case i of
--- a/src/Servant/Common/Req.hs
+++ b/src/Servant/Common/Req.hs
@ -9,20 +9,19 @@
 module Servant.Common.Req where

 -------------------------------------------------------------------------------
-import           Control.Applicative (liftA2, liftA3)
+import           Control.Applicative        (liftA2, liftA3)
 import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified Data.Map as Map
-import           Data.Maybe
-import           Data.Monoid
-import           Data.Proxy (Proxy(..))
-import           Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import           Reflex
+import qualified Data.Map                   as Map
+import           Data.Maybe                 (catMaybes)
+import           Data.Monoid                ((<>))
+import           Data.Proxy                 (Proxy(..))
+import           Data.Text                  (Text)
+import qualified Data.Text                  as T
+import qualified Data.Text.Encoding         as TE
 import           Reflex.Dom
-import           Servant.Common.BaseUrl
-import           Servant.API.ContentTypes
-import           Web.HttpApiData
+import           Servant.Common.BaseUrl     (BaseUrl, showBaseUrl, SupportsServantReflex)
+import           Servant.API.ContentTypes   (MimeUnrender(..), NoContent(..))
+import           Web.HttpApiData            (ToHttpApiData(..))
 -------------------------------------------------------------------------------
 import           Servant.API.BasicAuth

@ -90,14 +89,12 @@ displayHttpRequest :: Text -> Text
 displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

 -- | This function actually performs the request.
-performRequest :: forall t m.MonadWidget t m
+performRequest :: forall t m.(SupportsServantReflex t m)
               => Text
               -> Req t
               -> Dynamic t BaseUrl
               -> Event t ()
               -> m (Event t XhrResponse, Event t Text)
-               -- -> ExceptT ServantError IO ( Int, ByteString, MediaType
-               --                            , [HTTP.Header], Response ByteString)
 performRequest reqMeth req reqHost trigger = do

  let t :: Dynamic t [Either Text Text]
@ -210,15 +207,18 @@ bytesToPayload :: BL.ByteString -> XhrPayload
 bytesToPayload = T.pack . BL.unpack
 #endif

-performRequestNoBody ::
-  forall t m .MonadWidget t m => Text -> Req t -> Dynamic t BaseUrl
-                              -> Event t () -> m (Event t (ReqResult NoContent))
+performRequestNoBody :: forall t m .(SupportsServantReflex t m)
+                     => Text
+                     -> Req t
+                     -> Dynamic t BaseUrl
+                     -> Event t () -> m (Event t (ReqResult NoContent))
 performRequestNoBody reqMeth req reqHost trigger = do
  (resp, badReq) <- performRequest reqMeth req reqHost trigger
  return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]


-performRequestCT :: (MonadWidget t m, MimeUnrender ct a)
+performRequestCT :: (SupportsServantReflex t m,
+                     MimeUnrender ct a)
                 => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl
                 -> Event t () -> m (Event t (ReqResult a))
 performRequestCT ct reqMeth req reqHost trigger = do
--- a/src/Servant/Reflex.hs
+++ b/src/Servant/Reflex.hs
@ -23,22 +23,43 @@ module Servant.Reflex
  , module Servant.Common.BaseUrl
  ) where

+-------------------------------------------------------------------------------
 import           Control.Applicative
+import           Data.Monoid             ((<>))
 import qualified Data.Set                as Set
 import qualified Data.Text.Encoding      as E
 import           Data.CaseInsensitive    (mk)
-import           Data.Proxy
-import           Data.String.Conversions
+import           Data.Proxy              (Proxy (..))
 import qualified Data.Map                as Map
 import           Data.Text               (Text)
 import qualified Data.Text               as T
-import           Data.Text.Encoding
-import           GHC.TypeLits
-import           Servant.API
-import           Servant.Common.BaseUrl
-import           Servant.Common.Req
-import           Reflex
-import           Reflex.Dom
+import           GHC.TypeLits            (KnownSymbol, symbolVal)
+import           Servant.API             ((:<|>)(..),(:>), BasicAuth,
+                                          BasicAuthData, BuildHeadersTo(..),
+                                          Capture, contentType, Header,
+                                          Headers(..), HttpVersion, IsSecure,
+                                          MimeRender(..), MimeUnrender,
+                                          NoContent, QueryFlag, QueryParam,
+                                          QueryParams, Raw, ReflectMethod(..),
+                                          RemoteHost, ReqBody,
+                                          ToHttpApiData(..), Vault, Verb)
+import           Servant.Common.BaseUrl  (BaseUrl, baseUrlWidget, showBaseUrl,
+                                          SupportsServantReflex)
+import           Servant.Common.Req      (Req, ReqResult(..), QParam(..),
+                                          QueryPart(..), addHeader, authData,
+                                          defReq, prependToPathParts,
+                                          performRequestCT,
+                                          performRequestNoBody,
+                                          qParamToQueryPart, reqBody,
+                                          reqSuccess, reqFailure,
+                                          reqMethod, respHeaders, response,
+                                          qParams)
+import           Reflex.Dom              (Dynamic, Event, Reflex,
+                                          XhrRequest(..),
+                                          XhrResponseHeaders(..),
+                                          XhrResponse(..), ffor, fmapMaybe,
+                                          leftmost, performRequestAsync,
+                                          tagPromptlyDyn )

 -- * Accessing APIs as a Client

@ -78,13 +99,13 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
 -- >
 -- > myApi :: Proxy MyApi = Proxy
 -- >
-- > getBook :: MonadWidget t m
+-- > getBook :: SupportsServantReflex t m
 --           => Dynamic t BaseUrl
 --           -> Dynamic t (Maybe Text)
 --           -> Event t ()
 --           -> m (Event t (Either XhrError (Text, Book)))
 -- > getBook = client myApi (constDyn host)
-instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)
+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)
      => HasClient t m (Capture capture a :> sublayout) where

  type Client t m (Capture capture a :> sublayout) =
@ -101,7 +122,7 @@ instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)
 -- VERB (Returning content) --
 instance {-# OVERLAPPABLE #-}
  -- Note [Non-Empty Content Types]
-  (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m
+  (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
  ) => HasClient t m (Verb method status cts' a) where
  type Client t m (Verb method status cts' a) =
    Event t () -> m (Event t (ReqResult a))
@ -109,12 +130,12 @@ instance {-# OVERLAPPABLE #-}
    -- ExceptT ServantError IO a
  clientWithRoute Proxy _ req baseurl =
    performRequestCT (Proxy :: Proxy ct) method req' baseurl
-      where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
+      where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
            req' = req { reqMethod = method }

 -- -- VERB (No content) --
 instance {-# OVERLAPPING #-}
-  (ReflectMethod method, MonadWidget t m) =>
+  (ReflectMethod method, SupportsServantReflex t m) =>
  HasClient t m (Verb method status cts NoContent) where
  type Client t m (Verb method status cts NoContent) =
    Event t () -> m (Event t (ReqResult NoContent))
@ -122,7 +143,7 @@ instance {-# OVERLAPPING #-}
    -- ExceptT ServantError IO NoContent
  clientWithRoute Proxy _ req baseurl =
    performRequestNoBody method req baseurl
-      where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
+      where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

 toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
 toHeaders r =
@ -152,7 +173,7 @@ instance {-# OVERLAPPABLE #-}
  -- Note [Non-Empty Content Types]
  ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
    ReflectMethod method, cts' ~ (ct ': cts),
-    MonadWidget t m
+    SupportsServantReflex t m
  ) => HasClient t m (Verb method status cts' (Headers ls a)) where
  type Client t m (Verb method status cts' (Headers ls a)) =
    Event t () -> m (Event t (ReqResult (Headers ls a)))
@ -167,7 +188,7 @@ instance {-# OVERLAPPABLE #-}
 -- HEADERS Verb (No content) --
 instance {-# OVERLAPPABLE #-}
  ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
-    MonadWidget t m
+    SupportsServantReflex t m
  ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
  type Client t m (Verb method status cts (Headers ls NoContent))
    = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))
@ -194,7 +215,7 @@ instance {-# OVERLAPPABLE #-}
 -- > -- then you can just use "viewRefer" to query that endpoint
 -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
 instance (KnownSymbol sym, ToHttpApiData a,
-          HasClient t m sublayout, MonadWidget t m)
+          HasClient t m sublayout, SupportsServantReflex t m)
      => HasClient t m (Header sym a :> sublayout) where

  type Client t m (Header sym a :> sublayout) =
@ -346,7 +367,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
 -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- back the full `Response`.
 -- TODO redo
-instance (MonadWidget t m) => HasClient t m Raw where
+instance SupportsServantReflex t m => HasClient t m Raw where
  type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))
                      -> Event t ()
                      -> m (Event t (ReqResult ()))