element
@@ -348,5 +337,5 @@
return $ fmap (const k) (_link_clicked a)
class HasAttributes a where
- type Attrs a :: *
+ type Attrs a :: Type
attributes :: Lens' a (Attrs a)
diff --git a/src/Reflex/Dom/Widget/Input.hs b/src/Reflex/Dom/Widget/Input.hs
--- a/src/Reflex/Dom/Widget/Input.hs
+++ b/src/Reflex/Dom/Widget/Input.hs
@@ -13,12 +13,14 @@
{-# LANGUAGE TemplateHaskell #-}
#endif
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where
import Prelude
import Control.Lens hiding (element, ix)
+import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader
@@ -27,18 +29,15 @@
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.Functor.Misc
+import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
-import Data.Semigroup
import Data.Text (Text)
import qualified Data.Text as T
-import qualified GHCJS.DOM.GlobalEventHandlers as Events
-import GHCJS.DOM.EventM (on)
-import qualified GHCJS.DOM.FileList as FileList
import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
-import GHCJS.DOM.Types (MonadJSM, File, uncheckedCastTo)
+import GHCJS.DOM.Types (File, uncheckedCastTo)
import qualified GHCJS.DOM.Types as DOM (HTMLElement(..), EventTarget(..))
import Reflex.Class
import Reflex.Collection
@@ -48,7 +47,6 @@
import Reflex.Dom.Widget.Basic
import Reflex.Dynamic
import Reflex.PostBuild.Class
-import Reflex.TriggerEvent.Class
import qualified Text.Read as T
import qualified GHCJS.DOM.Event as Event
@@ -235,7 +233,7 @@
, _checkbox_change = _inputElement_checkedChange i
}
-type family CheckboxViewEventResultType (en :: EventTag) :: * where
+type family CheckboxViewEventResultType (en :: EventTag) :: Type where
CheckboxViewEventResultType 'ClickTag = Bool
CheckboxViewEventResultType t = EventResultType t
@@ -292,7 +290,7 @@
-- | Create a view only checkbox
{-# INLINABLE checkboxView #-}
-checkboxView :: forall t m. (DomBuilder t m, DomBuilderSpace m ~ GhcjsDomSpace, PostBuild t m, MonadHold t m) => Dynamic t (Map Text Text) -> Dynamic t Bool -> m (Event t Bool)
+checkboxView :: forall t m. (DomBuilder t m, DomBuilderSpace m ~ GhcjsDomSpace, PostBuild t m) => Dynamic t (Map Text Text) -> Dynamic t Bool -> m (Event t Bool)
checkboxView dAttrs dValue = do
let permanentAttrs = "type" =: "checkbox"
modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.union permanentAttrs) dAttrs
@@ -338,7 +336,7 @@
def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
}
-fileInput :: forall t m. (MonadIO m, MonadJSM m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)
+fileInput :: forall t m. (MonadIO m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)
=> FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
fileInput config = do
let insertType = Map.insert "type" "file"
@@ -371,7 +369,7 @@
, _dropdownConfig_attributes = constDyn mempty
}
-type family DropdownViewEventResultType (en :: EventTag) :: * where
+type family DropdownViewEventResultType (en :: EventTag) :: Type where
DropdownViewEventResultType 'ChangeTag = Text
DropdownViewEventResultType t = EventResultType t
@@ -437,9 +435,12 @@
let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os
in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)
modifyAttrs <- dynamicAttributesToModifyAttributes attrs
+ postBuild <- getPostBuild
+ let setSelection = attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys $
+ leftmost [setK, k0 <$ postBuild]
let cfg = def
& selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
- & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)
+ & selectElementConfig_setValue .~ fmap (T.pack . show) setSelection
(eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do
let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey
elDynAttr "option" optionAttrs $ dynText v
@@ -626,9 +627,6 @@
type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)
attributes = fileInputConfig_attributes
-class HasSetValue a where
- type SetValue a :: *
- setValue :: Lens' a (SetValue a)
instance HasSetValue (TextAreaConfig t) where
type SetValue (TextAreaConfig t) = Event t Text
@@ -651,7 +649,7 @@
setValue = checkboxConfig_setValue
class HasValue a where
- type Value a :: *
+ type Value a :: Type
value :: a -> Value a
instance HasValue (InputElement er d t) where
diff --git a/src/Reflex/Dom/Widget/Lazy.hs b/src/Reflex/Dom/Widget/Lazy.hs
--- a/src/Reflex/Dom/Widget/Lazy.hs
+++ b/src/Reflex/Dom/Widget/Lazy.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
module Reflex.Dom.Widget.Lazy where
import Reflex.Class
@@ -20,14 +21,13 @@
import Data.Fixed
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import GHCJS.DOM.Element
import GHCJS.DOM.Types (MonadJSM)
-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
-virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
+virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k, Eq v)
=> Dynamic t Int -- ^ The height of the visible region in pixels
-> Int -- ^ The height of each row in pixels
-> Dynamic t Int -- ^ The total number of items
@@ -117,7 +117,7 @@
"overflow" =: "hidden" <>
"position" =: "relative"
mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>
- "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>
+ "top" =: (<> "px") (T.pack $ show $ keyToIndex k * rowPx) <>
"position" =: "absolute" <>
"width" =: "100%"
findWindow sizeIncrement windowSize startingPosition =
diff --git a/src/Reflex/Dom/Widget/Resize.hs b/src/Reflex/Dom/Widget/Resize.hs
--- a/src/Reflex/Dom/Widget/Resize.hs
+++ b/src/Reflex/Dom/Widget/Resize.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
module Reflex.Dom.Widget.Resize where
import Reflex.Class
@@ -16,12 +17,10 @@
import Reflex.PostBuild.Class
import Reflex.TriggerEvent.Class
-import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import GHCJS.DOM.Element
@@ -37,19 +36,19 @@
-- This function can cause strange scrollbars to appear in some circumstances.
-- These can be hidden with pseudo selectors, for example, in webkit browsers:
-- .wrapper *::-webkit-scrollbar { width: 0px; background: transparent; }
-resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)
+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetector = resizeDetectorWithStyle ""
resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
=> Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
-> m a -- ^ The embedded widget
- -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
=> Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
-> m a -- ^ The embedded widget
- -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
resizeDetectorWithAttrs attrs w = do
let childStyle = "position: absolute; left: 0; top: 0;"
containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
@@ -91,4 +90,4 @@
size0 <- performEvent $ fmap (const $ liftJSM reset) pb
rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
- return (fmapMaybe void resize, w')
+ return (updated dimensions, w')
diff --git a/src/Reflex/Dom/Xhr.hs b/src/Reflex/Dom/Xhr.hs
--- a/src/Reflex/Dom/Xhr.hs
+++ b/src/Reflex/Dom/Xhr.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
@@ -8,6 +7,7 @@
#ifdef USE_TEMPLATE_HASKELL
{-# LANGUAGE TemplateHaskell #-}
#endif
+{-# LANGUAGE TypeOperators #-}
-- | A module for performing asynchronous HTTP calls from JavaScript
-- using the
@@ -159,6 +159,8 @@
import Data.Aeson.Encode
#endif
import qualified Data.ByteString.Lazy as BL
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
import Data.Default
import qualified Data.List as L
import Data.Map (Map)
@@ -171,7 +173,6 @@
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as B
import Data.Traversable
-import Data.Typeable
import Language.Javascript.JSaddle.Monad (JSM, askJSM, runJSM, MonadJSM, liftJSM)
@@ -180,7 +181,7 @@
, _xhrRequest_url :: Text
, _xhrRequest_config :: XhrRequestConfig a
}
- deriving (Show, Read, Eq, Ord, Typeable, Functor)
+ deriving (Show, Read, Eq, Ord, Functor)
data XhrRequestConfig a
= XhrRequestConfig { _xhrRequestConfig_headers :: Map Text Text
@@ -191,21 +192,20 @@
, _xhrRequestConfig_withCredentials :: Bool
, _xhrRequestConfig_responseHeaders :: XhrResponseHeaders
}
- deriving (Show, Read, Eq, Ord, Typeable, Functor)
+ deriving (Show, Read, Eq, Ord, Functor)
data XhrResponse
= XhrResponse { _xhrResponse_status :: Word
, _xhrResponse_statusText :: Text
, _xhrResponse_response :: Maybe XhrResponseBody
, _xhrResponse_responseText :: Maybe Text
- , _xhrResponse_headers :: Map Text Text
+ , _xhrResponse_headers :: Map (CI Text) Text
}
- deriving (Typeable)
data XhrResponseHeaders =
- OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response
+ OnlyHeaders (Set.Set (CI Text)) -- ^ Parse a subset of headers from the XHR Response
| AllHeaders -- ^ Parse all headers from the XHR Response
- deriving (Show, Read, Eq, Ord, Typeable)
+ deriving (Show, Read, Eq, Ord)
instance Default XhrResponseHeaders where
def = OnlyHeaders mempty
@@ -237,7 +237,7 @@
-- the XHR connection), and will pass an exception ('XhrException') to the
-- continuation if the connection cannot be made (or is aborted).
newXMLHttpRequestWithError
- :: (HasJSContext m, MonadJSM m, IsXhrPayload a)
+ :: (MonadJSM m, IsXhrPayload a)
=> XhrRequest a
-- ^ The request to make.
-> (Either XhrException XhrResponse -> JSM ())
@@ -275,7 +275,7 @@
AllHeaders -> parseAllHeadersString <$>
xmlHttpRequestGetAllResponseHeaders xhr
OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
- (Map.fromSet id xs)
+ (Map.fromSet CI.original xs)
_ <- liftJSM $ cb $ Right
XhrResponse { _xhrResponse_status = status
, _xhrResponse_statusText = statusText
@@ -288,12 +288,12 @@
return ()
return xhr
-parseAllHeadersString :: Text -> Map Text Text
+parseAllHeadersString :: Text -> Map (CI Text) Text
parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
- where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
+ where stripBoth (txt1, txt2) = (CI.mk $ T.strip txt1, T.strip $ T.drop 1 txt2)
-newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
+newXMLHttpRequest :: (MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
-- | Given Event of requests, issue them when the Event fires.
@@ -302,20 +302,20 @@
-- The request is processed asynchronously, therefore handling does
-- not block or cause a delay while creating the connection.
performRequestAsyncWithError
- :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a)
+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a)
=> Event t (XhrRequest a)
-> m (Event t (Either XhrException XhrResponse))
performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return
-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.
-performRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)
+performRequestAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)
performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return
-- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.
-performMkRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse)
+performMkRequestAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse)
performMkRequestAsync = performRequestAsync' newXMLHttpRequest
-performRequestAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a)
+performRequestAsync' :: (PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a)
performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do
r <- hr
_ <- newXhr r $ liftIO . cb
@@ -331,16 +331,16 @@
-- Order of request execution and completion is not guaranteed, but
-- order of creation and the collection result is preserved.
performRequestsAsyncWithError
- :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a)
+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a)
=> Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))
performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return
-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
-performRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))
+performRequestsAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))
performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return
-- | Builds and issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
-performMkRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse))
+performMkRequestsAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse))
performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest
performRequestsAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f) => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (f (XhrRequest b))) -> m (Event t (f a))
@@ -354,7 +354,7 @@
return ()
-- | Simplified interface to "GET" URLs and return decoded results.
-getAndDecode :: (MonadIO m, MonadJSM (Performable m), PerformEvent t m, HasJSContext (Performable m), TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a))
+getAndDecode :: (MonadIO m, MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a))
getAndDecode url = do
r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
return $ fmap decodeXhrResponse r
@@ -444,7 +444,7 @@
xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4
{-# INLINE xhrResponse_responseText #-}
-xhrResponse_headers :: Lens' XhrResponse (Map Text Text)
+xhrResponse_headers :: Lens' XhrResponse (Map (CI Text) Text)
xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5
{-# INLINE xhrResponse_headers #-}
diff --git a/src/Reflex/Dom/Xhr/Exception.hs b/src/Reflex/Dom/Xhr/Exception.hs
--- a/src/Reflex/Dom/Xhr/Exception.hs
+++ b/src/Reflex/Dom/Xhr/Exception.hs
@@ -1,12 +1,9 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
module Reflex.Dom.Xhr.Exception where
import Control.Exception (Exception (..))
-import Data.Typeable
data XhrException = XhrException_Error
| XhrException_Aborted
- deriving (Show, Read, Eq, Ord, Typeable)
+ deriving (Show, Read, Eq, Ord)
instance Exception XhrException
diff --git a/src/Reflex/Dom/Xhr/Foreign.hs b/src/Reflex/Dom/Xhr/Foreign.hs
--- a/src/Reflex/Dom/Xhr/Foreign.hs
+++ b/src/Reflex/Dom/Xhr/Foreign.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
module Reflex.Dom.Xhr.Foreign (
@@ -15,7 +14,7 @@
import Data.ByteString (ByteString)
import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
import GHCJS.DOM.Enums
-import GHCJS.DOM.EventM (EventM, on)
+import GHCJS.DOM.EventM (EventM, on, onSync)
import GHCJS.DOM.EventTarget (dispatchEvent)
import GHCJS.DOM.Types (MonadJSM, ToJSString, FormData, Document, Blob (..), ArrayBuffer (..), JSVal, JSM, IsEvent, XMLHttpRequestProgressEvent, ProgressEvent, Event, XMLHttpRequestUpload, FromJSString, ArrayBufferView (..), liftJSM, castTo)
import GHCJS.DOM.XMLHttpRequest
@@ -114,7 +113,7 @@
xmlHttpRequestOntimeout = (`on` timeout)
xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())
-xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
+xmlHttpRequestOnreadystatechange = (`onSync` readyStateChange)
xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m ()
xmlHttpRequestSetTimeout = setTimeout
diff --git a/src/Reflex/Dom/Xhr/FormData.hs b/src/Reflex/Dom/Xhr/FormData.hs
--- a/src/Reflex/Dom/Xhr/FormData.hs
+++ b/src/Reflex/Dom/Xhr/FormData.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Reflex.Dom.Xhr.FormData
( postForms
+ , postForms'
, FormValue (..)
, fileToFormValue
)
@@ -13,7 +14,6 @@
import Data.Text (Text)
import Data.Traversable
import qualified GHCJS.DOM.FormData as FD
-import Foreign.JavaScript.TH
import GHCJS.DOM.File (getName)
import GHCJS.DOM.Types (File, IsBlob)
import Language.Javascript.JSaddle.Monad (MonadJSM, liftJSM)
@@ -26,19 +26,30 @@
-- | Performs a POST request with the provided FormData payload
postForms
- :: ( IsBlob blob, HasJSContext (Performable m), MonadJSM (Performable m)
+ :: ( IsBlob blob, MonadJSM (Performable m)
, PerformEvent t m, TriggerEvent t m
, Traversable f)
=> Text -- ^ The target url
-> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData"
-> m (Event t (f XhrResponse))
-postForms url payload = do
+postForms t = postForms' t def
+
+-- | Like 'postForms' but doesn't use a default 'XhrRequestConfig', so a custom one can be provided.
+postForms'
+ :: ( IsBlob blob, MonadJSM (Performable m)
+ , PerformEvent t m, TriggerEvent t m
+ , Traversable f)
+ => Text -- ^ The target url
+ -> XhrRequestConfig a
+ -> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData"
+ -> m (Event t (f XhrResponse))
+postForms' url cfg payload = do
performMkRequestsAsync $ ffor payload $ \fs -> for fs $ \u -> liftJSM $ do
fd <- FD.newFormData Nothing
iforM_ u $ \k v -> case v of
FormValue_Text t -> FD.append fd k t
FormValue_File b fn -> FD.appendBlob fd k b fn
- return $ xhrRequest "POST" url $ def & xhrRequestConfig_sendData .~ fd
+ return $ xhrRequest "POST" url $ cfg & xhrRequestConfig_sendData .~ fd
-- | Converts a File (e.g., the output of a 'FileInput') into a 'FormValue'. The filename will be included if it is available.
fileToFormValue :: MonadJSM m => File -> m (FormValue File)
diff --git a/src/Reflex/Dom/Xhr/ResponseType.hs b/src/Reflex/Dom/Xhr/ResponseType.hs
--- a/src/Reflex/Dom/Xhr/ResponseType.hs
+++ b/src/Reflex/Dom/Xhr/ResponseType.hs
@@ -1,10 +1,7 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
module Reflex.Dom.Xhr.ResponseType where
import Data.ByteString (ByteString)
import Data.Text (Text)
-import Data.Typeable
import GHCJS.DOM.Blob (Blob)
data XhrResponseType
@@ -12,7 +9,7 @@
| XhrResponseType_ArrayBuffer
| XhrResponseType_Blob
| XhrResponseType_Text
- deriving (Show, Read, Eq, Ord, Typeable)
+ deriving (Show, Read, Eq, Ord)
data XhrResponseBody
= XhrResponseBody_Default Text
diff --git a/test/gc.hs b/test/gc.hs
--- a/test/gc.hs
+++ b/test/gc.hs
@@ -11,7 +11,6 @@
import Data.Text as T
import Language.Javascript.JSaddle.Warp
import Reflex.Dom.Core
-import Reflex.Time
import System.Exit
import System.Mem
import System.Process
@@ -20,7 +19,7 @@
import Test.Util.UnshareNetwork
#if MIN_VERSION_base(4,11,0)
-import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)
+import GHC.Stats (getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)
currentBytesUsed :: RTSStats -> Int64
currentBytesUsed = fromIntegral . gcdetails_live_bytes . gc
#else
@@ -47,7 +46,7 @@
main :: IO ()
main = do
- handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
+ handle (\(_ :: IOError) -> return ()) $ unshareNetwork -- If we run into an exception with sandboxing, just don't bother
withSandboxedChromeFlags True $ \chromeFlags -> do
mainThread <- myThreadId
browserProcess <- spawnCommand $ mconcat
diff --git a/test/hlint.hs b/test/hlint.hs
--- a/test/hlint.hs
+++ b/test/hlint.hs
@@ -1,10 +1,11 @@
-import Language.Haskell.HLint3 (hlint)
+import Language.Haskell.HLint (hlint)
import System.Exit (exitFailure, exitSuccess)
main :: IO ()
main = do
ideas <- hlint
[ "."
+ , "--ignore=Functor law"
, "--ignore=Redundant do"
, "--ignore=Use camelCase"
, "--ignore=Redundant $"
@@ -20,7 +21,9 @@
, "--ignore=Unnecessary hiding" -- Interferes with cross-version compatibility
, "--ignore=Use <$>"
, "--ignore=Reduce duplication" --TODO: Re-enable this test
+ , "--ignore=Eta reduce" -- simplified subsumption
, "--ignore=Use list comprehension"
+ , "--ignore=Evaluate"
, "--cpp-define=USE_TEMPLATE_HASKELL"
]
if null ideas then exitSuccess else exitFailure
diff --git a/test/hydration.hs b/test/hydration.hs
--- a/test/hydration.hs
+++ b/test/hydration.hs
@@ -1,13 +1,10 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -15,13 +12,27 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- Notice to those working on this test suite:
+-- It doesn't appear to be possible to use --match to run a particular test, in
+-- this situation the test may hang before reaching our code. This seems to
+-- happen when the test is not the first test in the block. As a workaround, you
+-- can just comment out the other tests. Also, using `xit` will cause the same
+-- issue. `xit` tests must be the last tests in the session, or the session will
+-- hang in the following test.
+
import Prelude hiding (fail)
import Control.Concurrent
+import qualified Control.Concurrent.Async as Async
+import Control.Lens.Operators
import Control.Monad hiding (fail)
import Control.Monad.Catch
import Control.Monad.Fail
@@ -31,12 +42,13 @@
import Data.Constraint.Extras
import Data.Constraint.Extras.TH
import Data.Dependent.Map (DMap)
-import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
+import Data.Dependent.Sum (DSum(..), (==>))
import Data.Functor.Identity
import Data.Functor.Misc
import Data.GADT.Compare.TH
import Data.GADT.Show.TH
import Data.IORef (IORef)
+import Data.List (sort)
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
@@ -55,14 +67,13 @@
import System.IO.Temp
import System.Process
import System.Which (staticWhich)
-import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
+import qualified Test.HUnit as HUnit
import qualified Test.Hspec as H
import qualified Test.Hspec.Core.Spec as H
import Test.Hspec (xit)
import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
import qualified Test.Hspec.WebDriver as WD
import Test.WebDriver (WD(..))
-import Test.WebDriver.Exceptions (ServerError(..))
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Dependent.Map as DMap
@@ -78,6 +89,11 @@
import Test.Util.ChromeFlags
import Test.Util.UnshareNetwork
+
+#if !MIN_VERSION_webdriver(0,10,0)
+deriving instance MonadMask WD
+#endif
+
chromium :: FilePath
chromium = $(staticWhich "chromium")
@@ -93,26 +109,22 @@
writeRef r = WD . writeRef r
assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
-assertEqual a b = liftIO . HUnit.assertEqual a b
+assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
assertFailure :: MonadIO m => String -> m ()
assertFailure = liftIO . HUnit.assertFailure
+assertBool :: (MonadIO m) => String -> Bool -> m ()
+assertBool msg bool = liftIO $ HUnit.assertBool msg bool
+
chromeConfig :: Text -> [Text] -> WD.WDConfig
chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
-keyMap :: DMap DKey Identity
-keyMap = DMap.fromList
- [ Key_Int ==> 0
- , Key_Char ==> 'A'
- ]
-
data DKey a where
Key_Int :: DKey Int
Key_Char :: DKey Char
Key_Bool :: DKey Bool
-
textKey :: DKey a -> Text
textKey = \case
Key_Int -> "Key_Int"
@@ -124,11 +136,26 @@
deriveGCompare ''DKey
deriveGShow ''DKey
+keyMap :: DMap DKey Identity
+keyMap = DMap.fromList
+ [ Key_Int ==> 0
+ , Key_Char ==> 'A'
+ ]
+
+data Key2 a where
+ Key2_Int :: Int -> Key2 Int
+ Key2_Char :: Char -> Key2 Char
+
+deriveGEq ''Key2
+deriveGCompare ''Key2
+deriveGShow ''Key2
+deriveArgDict ''Key2
+
deriving instance MonadFail WD
main :: IO ()
main = do
- unshareNetork
+ unshareNetwork
isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
withSeleniumServer $ \selenium -> do
@@ -137,25 +164,25 @@
withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
- hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
-tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
tests withDebugging wdConfig caps _selenium = do
let putStrLnDebug :: MonadIO m => Text -> m ()
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
- session' = sessionWith wdConfig "" . using (map (,"") caps)
+ session' t = sessionWith wdConfig t . using caps
runWD m = runWDOptions (WdOptions False) $ do
putStrLnDebug "before"
r <- m
putStrLnDebug "after"
return r
- testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
+ testWidgetStatic :: WD b -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -> WD b
testWidgetStatic = testWidgetStaticDebug withDebugging
- testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
- testWidget = testWidgetDebug withDebugging
- testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
- testWidget' = testWidgetDebug' withDebugging
- describe "text" $ session' $ do
+ testWidget :: WD () -> WD b -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -> WD b
+ testWidget = testWidgetDebug True withDebugging
+ testWidget' :: WD a -> (a -> WD b) -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -> WD b
+ testWidget' = testWidgetDebug' True withDebugging
+ session' "text" $ do
it "works" $ runWD $ do
testWidgetStatic (checkBodyText "hello world") $ do
text "hello world"
@@ -216,7 +243,7 @@
click <- button ""
void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
- describe "element" $ session' $ do
+ session' "element" $ do
it "works with domEvent Click" $ runWD $ do
clickedRef <- liftIO $ newRef False
testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -280,21 +307,78 @@
let click = domEvent Click e
return ()
- describe "inputElement" $ do
- describe "hydration" $ session' $ do
+ session' "inputElement" $ do
+ describe "static renderer" $ do
+ it "sets value attribute" $ runWD $ do
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ testWidget' checkStatic checkHydrated $ void $ inputElement $ def
+ & inputElementConfig_initialValue .~ "test"
+ it "updates value attribute at postBuild" $ runWD $ do
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ _ <- inputElement $ def
+ & inputElementConfig_initialValue .~ "test"
+ & inputElementConfig_setValue .~ ("test-updated" <$ pb)
+ pure ()
+ it "sets checked attr appropriately" $ runWD $ do
+ setCheckedChan <- liftIO newChan
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ pure e
+ checkValue e = do
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ WD.moveToCenter e
+ WD.click e -- Click to uncheck
+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
+ liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ testWidget' checkStatic checkValue $ do
+ setChecked <- triggerEventWithChan setCheckedChan
+ _ <- inputElement $ def
+ & initialAttributes .~ "type" =: "checkbox"
+ & inputElementConfig_initialChecked .~ True
+ & inputElementConfig_setChecked .~ setChecked
+ pure ()
+ it "sets checked attr appropriately at postbuild" $ runWD $ do
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ pure e
+ checkValue e = do
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ testWidget' checkStatic checkValue $ do
+ pb <- getPostBuild
+ _ <- inputElement $ def
+ & initialAttributes .~ "type" =: "checkbox"
+ & inputElementConfig_initialChecked .~ False
+ & inputElementConfig_setChecked .~ (True <$ pb)
+ pure ()
+ describe "hydration" $ do
it "doesn't wipe user input when switching over" $ runWD $ do
- inputRef <- newRef ("" :: Text)
+ inputRef <- newRef ("hello " :: Text)
testWidget'
(do
e <- findElemWithRetry $ WD.ByTag "input"
- WD.sendKeys "hello world" e
+ WD.sendKeys "world" e
pure e)
(\e -> do
WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
WD.click =<< findElemWithRetry (WD.ByTag "button")
readRef inputRef `shouldBeWithRetryM` "hello world"
) $ do
- e <- inputElement def
+ e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
click <- button "save"
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
it "captures user input after switchover" $ runWD $ do
@@ -351,24 +435,49 @@
checkedByUIRef <- newRef False
checkedRef <- newRef False
setCheckedChan <- liftIO newChan
- let checkValue = do
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
+ pure e
+ checkValue e = do
readRef checkedByUIRef `shouldBeWithRetryM` False
readRef checkedRef `shouldBeWithRetryM` False
- e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
WD.moveToCenter e
WD.click e
readRef checkedByUIRef `shouldBeWithRetryM` True
readRef checkedRef `shouldBeWithRetryM` True
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
liftIO $ writeChan setCheckedChan False
readRef checkedByUIRef `shouldBeWithRetryM` True
readRef checkedRef `shouldBeWithRetryM` False
- testWidget (pure ()) checkValue $ do
+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
+ testWidget' checkStatic checkValue $ do
setChecked <- triggerEventWithChan setCheckedChan
e <- inputElement $ def
& initialAttributes .~ "type" =: "checkbox"
& inputElementConfig_setChecked .~ setChecked
performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
+ it "respects user updates to checked which happen before hydration" $ runWD $ do
+ checkedByUIRef <- newRef False
+ checkedRef <- newRef False
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
+ WD.moveToCenter e
+ WD.click e
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ pure e
+ checkValue e = do
+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
+ readRef checkedByUIRef `shouldBeWithRetryM` True
+ readRef checkedRef `shouldBeWithRetryM` True
+ testWidget' checkStatic checkValue $ do
+ e <- inputElement $ def
+ & initialAttributes .~ "type" =: "checkbox"
+ performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
+ performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
it "captures file uploads" $ runWD $ do
filesRef :: IORef [Text] <- newRef []
let uploadFile = do
@@ -384,8 +493,117 @@
prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
names <- liftJSM $ traverse File.getName fs
liftIO $ writeRef filesRef names
-
- describe "hydration/immediate" $ session' $ do
+ it "fires _input event if the user altered the value before hydration" $ runWD $ do
+ input <- newRef ("" :: Text)
+ update <- newRef ("" :: Text)
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "value" `shouldBeWithRetryM` Just ""
+ WD.sendKeys "test" e
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ readRef input `shouldBeWithRetryM` "test"
+ readRef update `shouldBeWithRetryM` "test"
+ testWidget' checkStatic checkHydrated $ do
+ e <- inputElement def
+ performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
+ performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
+ it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
+ input <- newRef (Nothing :: Maybe Text)
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
+ readRef input `shouldBeWithRetryM` Nothing
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
+ performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
+ it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
+ let checkBoth = do
+ input <- findElemWithRetry $ WD.ByTag "input"
+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
+ p <- findElemWithRetry (WD.ByTag "p")
+ shouldContainText "pb" p
+ testWidget checkBoth checkBoth $ do
+ pb <- getPostBuild
+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
+ el "p" $ dynText $ _inputElement_value e
+ it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
+ let checkStatic = do
+ input <- findElemWithRetry $ WD.ByTag "input"
+ h2_value <- findElemWithRetry (WD.ByTag "h2")
+ h3_input <- findElemWithRetry (WD.ByTag "h3")
+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
+ shouldContainText "pb" h2_value
+ shouldContainText "" h3_input
+ WD.sendKeys "abc" input
+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pb" h2_value
+ shouldContainText "" h3_input
+ pure (input, h2_value, h3_input)
+ checkHydrated (input, h2_value, h3_input) = do
+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pbabc" h3_input
+ shouldContainText "pbabc pb" h2_value
+ pure ()
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
+ el "h1" $ dynText $ _inputElement_value e
+ el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
+ el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
+ it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
+ let checkStatic = do
+ input <- findElemWithRetry $ WD.ByTag "input"
+ p <- findElemWithRetry (WD.ByTag "p")
+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
+ shouldContainText "pb" p
+ WD.sendKeys "abc" input
+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pb" p -- It won't be updated yet
+ pure (input, p)
+ checkHydrated (input, p) = do
+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pbabc" p
+ pure ()
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
+ el "p" $ dynText $ _inputElement_value e
+ it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
+ valRef <- newRef ([] :: [Text])
+ inputRef <- newRef ([] :: [Text])
+ let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
+ checkStatic = do
+ input <- findElemWithRetry $ WD.ByTag "input"
+ p <- findElemWithRetry (WD.ByTag "p")
+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
+ shouldContainText "pb" p
+ WD.sendKeys "abc" input
+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pb" p -- It won't be updated yet
+ readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
+ readRef valRef `shouldBeWithRetryM` ["pb"]
+ pure (input, p)
+ checkHydrated (input, p) = do
+ readRef inputRef `shouldBeWithRetryM` ["pbabc"]
+ readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pbabc" p
+ pure ()
+ testWidget' checkStatic checkHydrated $ do
+ liftIO $ writeRef valRef []
+ pb <- getPostBuild
+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
+ el "p" $ dynText $ _inputElement_value e
+ performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
+ performEvent_ $ consRef inputRef <$> _inputElement_input e
+ describe "hydration/immediate" $ do
it "captures user input after switchover" $ runWD $ do
inputRef :: IORef Text <- newRef ""
let checkValue = do
@@ -465,8 +683,31 @@
names <- liftJSM $ traverse File.getName fs
liftIO $ writeRef filesRef names
- describe "textAreaElement" $ do
- describe "hydration" $ session' $ do
+ session' "textAreaElement" $ do
+ describe "static renderer" $ do
+ it "sets value attribute" $ runWD $ do
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "textarea"
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
+ & textAreaElementConfig_initialValue .~ "test"
+ it "updates value attribute at postBuild" $ runWD $ do
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "textarea"
+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ _ <- textAreaElement $ def
+ & textAreaElementConfig_initialValue .~ "test"
+ & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
+ pure ()
+ describe "hydration" $ do
it "doesn't wipe user input when switching over" $ runWD $ do
inputRef <- newRef ("" :: Text)
testWidget'
@@ -532,8 +773,90 @@
e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
+ it "fires _input event if the user altered the value before hydration" $ runWD $ do
+ textarea <- newRef ("" :: Text)
+ update <- newRef ("" :: Text)
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "textarea"
+ WD.attr e "value" `shouldBeWithRetryM` Just ""
+ WD.sendKeys "test" e
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
+ readRef textarea `shouldBeWithRetryM` "test"
+ readRef update `shouldBeWithRetryM` "test"
+ testWidget' checkStatic checkHydrated $ do
+ e <- textAreaElement def
+ performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
+ performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
+ it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
+ textarea <- newRef (Nothing :: Maybe Text)
+ let checkStatic = do
+ e <- findElemWithRetry $ WD.ByTag "textarea"
+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
+ pure e
+ checkHydrated e = do
+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
+ readRef textarea `shouldBeWithRetryM` Nothing
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
+ performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
+ it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
+ let checkBoth = do
+ textarea <- findElemWithRetry $ WD.ByTag "textarea"
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
+ p <- findElemWithRetry (WD.ByTag "p")
+ shouldContainText "pb" p
+ testWidget checkBoth checkBoth $ do
+ pb <- getPostBuild
+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
+ el "p" $ dynText $ _textAreaElement_value e
+ it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
+ let checkStatic = do
+ textarea <- findElemWithRetry $ WD.ByTag "textarea"
+ h2_value <- findElemWithRetry (WD.ByTag "h2")
+ h3_input <- findElemWithRetry (WD.ByTag "h3")
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
+ shouldContainText "pb" h2_value
+ shouldContainText "" h3_input
+ WD.sendKeys "abc" textarea
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pb" h2_value
+ shouldContainText "" h3_input
+ pure (textarea, h2_value, h3_input)
+ checkHydrated (textarea, h2_value, h3_input) = do
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pbabc" h3_input
+ shouldContainText "pbabc pb" h2_value
+ pure ()
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
+ el "h1" $ dynText $ _textAreaElement_value e
+ el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
+ el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
+ it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
+ let checkStatic = do
+ textarea <- findElemWithRetry $ WD.ByTag "textarea"
+ p <- findElemWithRetry (WD.ByTag "p")
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
+ shouldContainText "pb" p
+ WD.sendKeys "abc" textarea
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pb" p -- It won't be updated yet
+ pure (textarea, p)
+ checkHydrated (textarea, p) = do
+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
+ shouldContainText "pbabc" p
+ pure ()
+ testWidget' checkStatic checkHydrated $ do
+ pb <- getPostBuild
+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
+ el "p" $ dynText $ _textAreaElement_value e
- describe "hydration/immediate" $ session' $ do
+ describe "hydration/immediate" $ do
it "captures user input after switchover" $ runWD $ do
inputRef :: IORef Text <- newRef ""
let checkValue = do
@@ -575,13 +898,13 @@
performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
- describe "selectElement" $ do
+ session' "selectElement" $ do
let options :: DomBuilder t m => m ()
options = do
elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
- describe "hydration" $ session' $ do
+ describe "hydration" $ do
it "sets initial value correctly" $ runWD $ do
inputRef <- newRef ("" :: Text)
let setup = do
@@ -655,7 +978,7 @@
performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
- describe "hydration/immediate" $ session' $ do
+ describe "hydration/immediate" $ do
it "captures user input after switchover" $ runWD $ do
inputRef :: IORef Text <- newRef ""
let checkValue = do
@@ -701,7 +1024,7 @@
performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
- describe "prerender" $ session' $ do
+ session' "prerender" $ do
it "works in simple case" $ runWD $ do
testWidget (checkBodyText "One") (checkBodyText "Two") $ do
prerender_ (text "One") (text "Two")
@@ -770,7 +1093,16 @@
prerender_ (pure ()) (liftIO $ trigger "Client")
textNode $ TextNodeConfig "Initial" $ Just e
- describe "runWithReplace" $ session' $ do
+ session' "namespaces" $ do
+ it "dyn can be nested in namespaced widget" $ runWD $ do
+ testWidget (pure ()) (checkTextInTag "svg" "one") $ do
+ let svgRootCfg = def
+ & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
+ & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
+ void $ element "svg" svgRootCfg $ do
+ dyn_ $ text "one" <$ pure ()
+
+ session' "runWithReplace" $ do
it "works" $ runWD $ do
replaceChan :: Chan Text <- liftIO newChan
let setup = findElemWithRetry $ WD.ByTag "div"
@@ -914,7 +1246,61 @@
, el "span" . text <$> replace
]
- describe "traverseDMapWithKeyWithAdjust" $ session' $ do
+ let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
+ it "removes bracketing comments" $ runWD $ do
+ replaceChan :: Chan () <- liftIO newChan
+ let
+ preSwitchover = checkInnerHtml "div" "before|inner1|after"
+ check () = do
+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
+ checkInnerHtml "div" "before|inner2
|after"
+ testWidget' preSwitchover check $ do
+ replace <- triggerEventWithChan replaceChan
+ el "div" $ do
+ text "before|"
+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
+ text "|after"
+ it "ignores extra ending bracketing comment" $ runWD $ do
+ replaceChan :: Chan () <- liftIO newChan
+ let
+ preSwitchover = checkInnerHtml "div" "before|inner1|after"
+ check () = do
+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
+ checkInnerHtml "div" "before|inner2|after"
+ testWidget' preSwitchover check $ do
+ replace <- triggerEventWithChan replaceChan
+ el "div" $ do
+ text "before|"
+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
+ text "|after"
+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
+ -- TODO This test actually causes a hydration failure, but it wasn't
+ -- previously detected, so I've marked it pending
+ xit "ignores missing ending bracketing comments" $ runWD $ do
+ replaceChan :: Chan () <- liftIO newChan
+ let
+ preSwitchover = do
+ checkInnerHtml "div" "before|inner1|after"
+ divEl <- findElemWithRetry (WD.ByTag "div")
+ let wrongHtml = "inner1"
+ actualHtml :: String <- WD.executeJS
+ [WD.JSArg divEl, WD.JSArg wrongHtml]
+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
+ actualHtml `shouldBe` wrongHtml
+ check () = do
+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
+ checkInnerHtml "div" "before|inner2
|after"
+ testWidget' preSwitchover check $ do
+ replace <- triggerEventWithChan replaceChan
+ el "div" $ do
+ text "before|"
+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
+ text "|after"
+
+ session' "traverseDMapWithKeyWithAdjust" $ do
let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
elClass "span" "key" $ text $ textKey k
@@ -1017,7 +1403,7 @@
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
liftIO $ dmap `H.shouldBe` keyMap
- describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
+ session' "traverseIntMapWithKeyWithAdjust" $ do
let textKeyInt k = "key" <> T.pack (show k)
intMap = IntMap.fromList
[ (1, "one")
@@ -1124,7 +1510,7 @@
(dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
liftIO $ dmap `H.shouldBe` intMap
- describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do
let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
elClass "span" "key" $ text $ textKey2 k
@@ -1204,8 +1590,8 @@
(dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
liftIO $ assertEqual "DMap" initMap dmap
- describe "hydrating invalid HTML" $ session' $ do
- it "can hydrate list in paragraph" $ runWD $ do
+ session' "hydrating invalid HTML" $ do
+ xit "can hydrate list in paragraph" $ runWD $ do
let preSwitchover = do
checkBodyText "before\ninner\nafter"
-- Two tags should be present
@@ -1222,7 +1608,8 @@
shouldContainText "before\ninner\nafter" p1
elementShouldBeRemoved ol
elementShouldBeRemoved p2
- testWidget' preSwitchover check $ do
+ -- Don't fail fatally when hydration encounters the invalid DOM
+ testWidgetDebug' False withDebugging preSwitchover check $ do
-- This is deliberately invalid HTML, the browser will interpret it as
--
before
inner
after
el "p" $ do
@@ -1230,6 +1617,29 @@
el "ol" $ text "inner"
text "after"
+ -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
+ -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
+ -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
+ session' "dropdown" $ do
+ let doTest expectedOpts (initialValue :: Text) = do
+ let doCheck = do
+ es <- findElemsWithRetry $ WD.ByTag "option"
+ opts <- mapM fetchElement es
+ assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
+ testWidget doCheck doCheck $ do
+ void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
+ fetchElement e = do
+ val <- WD.attr e "value"
+ sel <- WD.attr e "selected"
+ return (fromMaybe "" val, isJust sel)
+ -- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)
+ -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
+ xit "statically renders initial values (on aa)" $ runWD $ do
+ doTest [("0",True),("1",False)] "aa"
+ -- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well
+ xit "statically renders initial values (on bb)" $ runWD $ do
+ doTest [("0",False),("1",True)] "bb"
+
data Selenium = Selenium
{ _selenium_portNumber :: PortNumber
, _selenium_stopServer :: IO ()
@@ -1253,7 +1663,7 @@
, _selenium_stopServer = stopServer
}
-triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender js t m) => Chan a -> m (Event t a)
+triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender t m) => Chan a -> m (Event t a)
triggerEventWithChan chan = do
(e, trigger) <- newTriggerEvent
-- In prerender because we only want to do this on the client
@@ -1297,6 +1707,9 @@
findElemWithRetry :: Selector -> WD WD.Element
findElemWithRetry = withRetry . WD.findElem
+findElemsWithRetry :: Selector -> WD [WD.Element]
+findElemsWithRetry = withRetry . WD.findElems
+
getBody :: WD WD.Element
getBody = WD.findElem $ WD.ByTag "body"
@@ -1305,49 +1718,54 @@
where wait :: Int -> WD a
wait 0 = a
wait n = try a >>= \case
- Left (_ :: SomeException) -> do
- liftIO $ threadDelay 100000
+ Left (e :: SomeException) -> do
+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
wait $ n - 1
Right v -> return v
divId :: DomBuilder t m => Text -> m a -> m a
divId i = elAttr "div" ("id" =: i)
-type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)
+type TestWidget t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)
testWidgetStaticDebug
:: Bool
-> WD b
-- ^ Webdriver commands to run before JS runs and after hydration switchover
- -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+ -> (forall m. TestWidget (SpiderTimeline Global) m => m ())
-- ^ Widget we are testing
-> WD b
-testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
+testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
-- | TODO: do something about JSExceptions not causing tests to fail
testWidgetDebug
:: Bool
+ -> Bool
-> WD ()
-- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
-> WD b
-- ^ Webdriver commands to run after hydration switchover
- -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+ -> (forall m. TestWidget (SpiderTimeline Global) m => m ())
-- ^ Widget we are testing
-> WD b
-testWidgetDebug withDebugging beforeJS afterSwitchover =
- testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
+testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
+ testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
+data HydrationFailedException = HydrationFailedException deriving Show
+instance Exception HydrationFailedException
+
-- | TODO: do something about JSExceptions not causing tests to fail
testWidgetDebug'
:: Bool
+ -> Bool
-> WD a
-- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
-> (a -> WD b)
-- ^ Webdriver commands to run after hydration switchover
- -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+ -> (forall m. TestWidget (SpiderTimeline Global) m => m ())
-- ^ Widget we are testing (contents of body)
-> WD b
-testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
+testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
let putStrLnDebug :: MonadIO m => Text -> m ()
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
staticApp = do
@@ -1359,6 +1777,7 @@
((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
putStrLnDebug "rendered static"
waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
+ onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
let entryPoint = do
putStrLnDebug "taking waitBeforeJS"
@@ -1370,7 +1789,7 @@
liftIO $ putMVar waitUntilSwitchover ()
putStrLnDebug "put waitUntilSwitchover"
putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
- mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
syncPoint
application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
@@ -1388,29 +1807,23 @@
]
-- hSilence to get rid of ConnectionClosed logs
silenceIfDebug = if withDebugging then id else hSilence [stderr]
- jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
- jsaddleTid <- liftIO jsaddleWarp
- putStrLnDebug "taking waitJSaddle"
- liftIO $ takeMVar waitJSaddle
- putStrLnDebug "opening page"
- WD.openPage $ "http://localhost:" <> show jsaddlePort
- putStrLnDebug "running beforeJS"
- a <- beforeJS
- putStrLnDebug "putting waitBeforeJS"
- liftIO $ putMVar waitBeforeJS ()
- putStrLnDebug "taking waitUntilSwitchover"
- liftIO $ takeMVar waitUntilSwitchover
- putStrLnDebug "running afterSwitchover"
- b <- afterSwitchover a
- putStrLnDebug "killing jsaddle thread"
- liftIO $ killThread jsaddleTid
- return b
-
-data Key2 a where
- Key2_Int :: Int -> Key2 Int
- Key2_Char :: Char -> Key2 Char
+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
+ withAsync' jsaddleWarp $ do
+ putStrLnDebug "taking waitJSaddle"
+ liftIO $ takeMVar waitJSaddle
+ putStrLnDebug "opening page"
+ WD.openPage $ "http://localhost:" <> show jsaddlePort
+ putStrLnDebug "running beforeJS"
+ a <- beforeJS
+ putStrLnDebug "putting waitBeforeJS"
+ liftIO $ putMVar waitBeforeJS ()
+ putStrLnDebug "taking waitUntilSwitchover"
+ liftIO $ takeMVar waitUntilSwitchover
+ putStrLnDebug "running afterSwitchover"
+ afterSwitchover a
-deriveGEq ''Key2
-deriveGCompare ''Key2
-deriveGShow ''Key2
-deriveArgDict ''Key2
+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
+withAsync' f g = bracket
+ (liftIO $ Async.async f)
+ (liftIO . Async.uninterruptibleCancel)
+ (const g)