@@ -1,54 +1,39 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE ConstraintKinds #-}
5{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE TemplateHaskell #-}
16{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TupleSections #-}
17{-# LANGUAGE TypeApplications #-}
17{-# LANGUAGE TypeApplications #-}
18{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeFamilies #-}
19−{-# LANGUAGE UndecidableInstances #-}
21−{-# OPTIONS_GHC -fno-warn-orphans #-}
23−-- Notice to those working on this test suite:
24−-- It doesn't appear to be possible to use --match to run a particular test, in
25−-- this situation the test may hang before reaching our code. This seems to
26−-- happen when the test is not the first test in the block. As a workaround, you
27−-- can just comment out the other tests. Also, using `xit` will cause the same
28−-- issue. `xit` tests must be the last tests in the session, or the session will
29−-- hang in the following test.
31−import Prelude hiding (fail)
32import Control.Concurrent
20import Control.Concurrent
33−import qualified Control.Concurrent.Async as Async
34−import Control.Lens.Operators
35−import Control.Monad hiding (fail)
21+import Control.Monad
36import Control.Monad.Catch
22import Control.Monad.Catch
37−import Control.Monad.Fail
38import Control.Monad.Fix
23import Control.Monad.Fix
39import Control.Monad.IO.Class
24import Control.Monad.IO.Class
40import Control.Monad.Ref
25import Control.Monad.Ref
26+import Data.Constraint (Dict(..))
41import Data.Constraint.Extras
27import Data.Constraint.Extras
42−import Data.Constraint.Extras.TH
43import Data.Dependent.Map (DMap)
28import Data.Dependent.Map (DMap)
44−import Data.Dependent.Sum (DSum(..), (==>))
29+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
30+import Data.Foldable (traverse_)
45import Data.Functor.Identity
31import Data.Functor.Identity
46import Data.Functor.Misc
32import Data.Functor.Misc
47import Data.GADT.Compare.TH
33import Data.GADT.Compare.TH
48import Data.GADT.Show.TH
34import Data.GADT.Show.TH
49import Data.IORef (IORef)
35import Data.IORef (IORef)
50−import Data.List (sort)
36+import Data.Maybe (fromMaybe, fromJust)
52import Data.Proxy
37import Data.Proxy
53import Data.Text (Text)
38import Data.Text (Text)
54import Language.Javascript.JSaddle (syncPoint, liftJSM)
39import Language.Javascript.JSaddle (syncPoint, liftJSM)
@@ -58,22 +43,18 @@ import Network.Socket
58import Network.Wai
43import Network.Wai
59import Network.WebSockets
44import Network.WebSockets
60import Reflex.Dom.Core
45import Reflex.Dom.Core
61−import Reflex.Dom.Widget.Input (dropdown)
62import Reflex.Patch.DMapWithMove
46import Reflex.Patch.DMapWithMove
63import System.Directory
47import System.Directory
64−import System.Environment
65import System.IO (stderr)
48import System.IO (stderr)
66import System.IO.Silently
49import System.IO.Silently
67import System.IO.Temp
50import System.IO.Temp
68import System.Process
51import System.Process
69−import System.Which (staticWhich)
52+import System.Timeout.Lifted
70−import qualified Test.HUnit as HUnit
53+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
71import qualified Test.Hspec as H
54import qualified Test.Hspec as H
72−import qualified Test.Hspec.Core.Spec as H
73−import Test.Hspec (xit)
74−import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
55+import Test.Hspec.WebDriver hiding (runWD)
75import qualified Test.Hspec.WebDriver as WD
56import qualified Test.Hspec.WebDriver as WD
76−import Test.WebDriver (WD(..))
57+import Test.WebDriver (WD)
78import qualified Data.ByteString.Lazy as LBS
59import qualified Data.ByteString.Lazy as LBS
79import qualified Data.Dependent.Map as DMap
60import qualified Data.Dependent.Map as DMap
@@ -86,37 +67,20 @@ import qualified System.FilePath as FilePath
86import qualified Test.WebDriver as WD
67import qualified Test.WebDriver as WD
87import qualified Test.WebDriver.Capabilities as WD
68import qualified Test.WebDriver.Capabilities as WD
89−import Test.Util.ChromeFlags
90−import Test.Util.UnshareNetwork
92−-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
93−deriving instance MonadMask WD
96−chromium = $(staticWhich "chromium")
98−seleniumPort, jsaddlePort :: PortNumber
102-- TODO Remove orphan
70-- TODO Remove orphan
103−instance MonadRef WD where
71+deriving instance MonadRef WD
104− type Ref WD = Ref IO
105− newRef = WD . newRef
106− readRef = WD . readRef
107− writeRef r = WD . writeRef r
109assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
73assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
110−assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
74+assertEqual a b = liftIO . HUnit.assertEqual a b
112assertFailure :: MonadIO m => String -> m ()
76assertFailure :: MonadIO m => String -> m ()
113assertFailure = liftIO . HUnit.assertFailure
77assertFailure = liftIO . HUnit.assertFailure
115−assertBool :: (MonadIO m) => String -> Bool -> m ()
79+testTimeLimit :: Int
116−assertBool msg bool = liftIO $ HUnit.assertBool msg bool
80+testTimeLimit = 5 * 1000 * 1000
118−chromeConfig :: Text -> [Text] -> WD.WDConfig
82+chromeConfig :: Text -> WD.WDConfig
119−chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
83+chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
121keyMap :: DMap DKey Identity
85keyMap :: DMap DKey Identity
122keyMap = DMap.fromList
86keyMap = DMap.fromList
@@ -129,6 +93,14 @@ data DKey a where
129 Key_Char :: DKey Char
93 Key_Char :: DKey Char
130 Key_Bool :: DKey Bool
94 Key_Bool :: DKey Bool
96+instance ArgDict DKey where
97+ type ConstraintsFor DKey c = (c Int, c Char, c Bool)
98+ type ConstraintsFor' DKey c g = (c (g Int), c (g Char), c (g Bool))
103+ argDict' = undefined -- Missing constraints?
133textKey :: DKey a -> Text
105textKey :: DKey a -> Text
134textKey = \case
106textKey = \case
@@ -136,43 +108,34 @@ textKey = \case
136 Key_Char -> "Key_Char"
108 Key_Char -> "Key_Char"
137 Key_Bool -> "Key_Bool"
109 Key_Bool -> "Key_Bool"
140deriveGEq ''DKey
111deriveGEq ''DKey
141deriveGCompare ''DKey
112deriveGCompare ''DKey
142deriveGShow ''DKey
113deriveGShow ''DKey
144−deriving instance MonadFail WD
115+instance ShowTag DKey Identity where
116+ showTaggedPrec = \case
117+ Key_Int -> showsPrec
118+ Key_Char -> showsPrec
119+ Key_Bool -> showsPrec
121+instance EqTag DKey Identity where
122+ eqTagged Key_Int Key_Int = (==)
123+ eqTagged Key_Char Key_Char = (==)
124+ eqTagged Key_Bool Key_Bool = (==)
146main :: IO ()
126main :: IO ()
149− isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
150− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
151− withSeleniumServer $ \selenium -> do
127+main = withSeleniumServer $ \selenium -> do
152− let browserPath = T.strip $ T.pack chromium
128+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
153− when (T.null browserPath) $ fail "No browser found"
129+ when (T.null browserPath) $ fail "No browser found"
154− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
155− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
130+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
156− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
131+ chromeCaps' = WD.getCaps $ chromeConfig browserPath
157− hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
132+ hspec (tests wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
159−tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
134+tests :: WD.WDConfig -> [Capabilities] -> Selenium -> Spec
160−tests withDebugging wdConfig caps _selenium = do
135+tests wdConfig caps _selenium = do
161− let putStrLnDebug :: MonadIO m => Text -> m ()
162− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
163− session' t = sessionWith wdConfig t . using caps
136+ let session' = sessionWith wdConfig "" . using (map (,"") caps)
164− runWD m = runWDOptions (WdOptions False) $ do
137+ runWD = runWDOptions (WdOptions False)
165− putStrLnDebug "before"
138+ describe "text" $ session' $ do
167− putStrLnDebug "after"
169− testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
170− testWidgetStatic = testWidgetStaticDebug withDebugging
171− testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
172− testWidget = testWidgetDebug True withDebugging
173− testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
174− testWidget' = testWidgetDebug' True withDebugging
175− session' "text" $ do
176 it "works" $ runWD $ do
139 it "works" $ runWD $ do
177 testWidgetStatic (checkBodyText "hello world") $ do
140 testWidgetStatic (checkBodyText "hello world") $ do
178 text "hello world"
141 text "hello world"
@@ -214,38 +177,39 @@ tests withDebugging wdConfig caps _selenium = do
214 el "div" $ do
177 el "div" $ do
215 el "span" $ text "hello world"
178 el "span" $ text "hello world"
217−-- TODO I think these two tests are broken
180+ it "updates after postBuild" $ runWD $ do -- TODO I think these two tests are broken
218−-- it "updates after postBuild" $ runWD $ do
219−-- testWidget (checkBodyText "initial") (checkBodyText "after") $ do
181+ testWidget (checkBodyText "initial") (checkBodyText "after") $ do
220−-- after <- delay 0 =<< getPostBuild
182+ after <- delay 0 =<< getPostBuild
221−-- void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after
183+ void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after
222−-- it "updates immediately after postBuild" $ runWD $ do
184+ it "updates immediately after postBuild" $ runWD $ do
223−-- testWidget (checkBodyText "pb") (checkBodyText "after") $ do
185+ testWidget (checkBodyText "pb") (checkBodyText "after") $ do
224−-- pb <- getPostBuild
186+ pb <- getPostBuild
225−-- after <- delay 0 pb
187+ after <- delay 0 pb
226−-- void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]
188+ void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]
227 it "updates in immediate mode" $ runWD $ do
189 it "updates in immediate mode" $ runWD $ do
228 let checkUpdated = do
190 let checkUpdated = do
229 checkBodyText "initial"
191 checkBodyText "initial"
230− WD.click =<< findElemWithRetry (WD.ByTag "button")
192+ WD.click =<< WD.findElem (WD.ByTag "button")
193+ liftIO $ threadDelay 100000 -- wait for update
231 checkBodyText "after"
194 checkBodyText "after"
232 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
195 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
233 click <- button ""
196 click <- button ""
234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
197 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
236− session' "element" $ do
199+ describe "element" $ session' $ do
237 it "works with domEvent Click" $ runWD $ do
200 it "works with domEvent Click" $ runWD $ do
238 clickedRef <- liftIO $ newRef False
201 clickedRef <- liftIO $ newRef False
239− testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
202+ testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
240 (e, _) <- el' "div" $ text "hello world"
203 (e, _) <- el' "div" $ text "hello world"
241 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
204 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
242− readRef clickedRef `shouldBeWithRetryM` True
205+ clicked <- liftIO $ readRef clickedRef
206+ liftIO $ assertEqual "Not clicked" True clicked
243 it "works with eventFlags stopPropagation" $ runWD $ do
207 it "works with eventFlags stopPropagation" $ runWD $ do
244 firstClickedRef <- newRef False
208 firstClickedRef <- newRef False
245 secondClickedRef <- newRef False
209 secondClickedRef <- newRef False
246 let clickBoth = do
210 let clickBoth = do
247− findElemWithRetry (WD.ById "first") >>= WD.click
211+ WD.findElem (WD.ById "first") >>= WD.click
248− findElemWithRetry (WD.ById "second") >>= WD.click
212+ WD.findElem (WD.ById "second") >>= WD.click
249 testWidget (pure ()) clickBoth $ do
213 testWidget (pure ()) clickBoth $ do
250 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
214 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
251 void $ elAttr "span" ("id" =: "first") $ text "hello world"
215 void $ elAttr "span" ("id" =: "first") $ text "hello world"
@@ -262,7 +226,7 @@ tests withDebugging wdConfig caps _selenium = do
262 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
226 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
263 it "works with eventFlags preventDefault" $ runWD $ do
227 it "works with eventFlags preventDefault" $ runWD $ do
264 let click = do
228 let click = do
265− e <- findElemWithRetry $ WD.ByTag "input"
229+ e <- WD.findElem $ WD.ByTag "input"
266 s0 <- WD.isSelected e
230 s0 <- WD.isSelected e
267 WD.click e
231 WD.click e
268 s1 <- WD.isSelected e
232 s1 <- WD.isSelected e
@@ -276,7 +240,7 @@ tests withDebugging wdConfig caps _selenium = do
276 assertEqual "Click not prevented" (False, False) clicked
240 assertEqual "Click not prevented" (False, False) clicked
277 it "can add/update/remove attributes" $ runWD $ do
241 it "can add/update/remove attributes" $ runWD $ do
278 let checkInitialAttrs = do
242 let checkInitialAttrs = do
279− e <- findElemWithRetry $ WD.ByTag "div"
243+ e <- WD.findElem $ WD.ByTag "div"
280 assertAttr e "const" (Just "const")
244 assertAttr e "const" (Just "const")
281 assertAttr e "delete" (Just "delete")
245 assertAttr e "delete" (Just "delete")
282 assertAttr e "init" (Just "init")
246 assertAttr e "init" (Just "init")
@@ -284,11 +248,11 @@ tests withDebugging wdConfig caps _selenium = do
285 checkModifyAttrs e = do
249 checkModifyAttrs e = do
286 WD.click e
250 WD.click e
287− withRetry $ do
251+ liftIO $ threadDelay 100000
288− assertAttr e "const" (Just "const")
252+ assertAttr e "const" (Just "const")
289− assertAttr e "delete" Nothing
253+ assertAttr e "delete" Nothing
290− assertAttr e "init" (Just "click")
254+ assertAttr e "init" (Just "click")
291− assertAttr e "click" (Just "click")
255+ assertAttr e "click" (Just "click")
292 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
256 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
293 let conf = def
257 let conf = def
294 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
258 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
@@ -296,87 +260,40 @@ tests withDebugging wdConfig caps _selenium = do
296 (e, ()) <- element "div" conf $ text "hello world"
260 (e, ()) <- element "div" conf $ text "hello world"
297 let click = domEvent Click e
261 let click = domEvent Click e
298 return ()
262 return ()
263+ -- TODO check this is the correct solution
264+ it "has ssr attribute, removes ssr attribute" $ runWD $ do
265+ let checkSSRAttr = do
266+ e <- WD.findElem $ WD.ByTag "div"
267+ assertAttr e "data-ssr" (Just "")
269+ testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
300− session' "inputElement" $ do
271+ describe "inputElement" $ do
301− describe "static renderer" $ do
272+ describe "hydration" $ session' $ do
302− it "sets value attribute" $ runWD $ do
303− let checkStatic = do
304− e <- findElemWithRetry $ WD.ByTag "input"
305− WD.attr e "value" `shouldBeWithRetryM` Just "test"
307− checkHydrated e = do
308− WD.attr e "value" `shouldBeWithRetryM` Just "test"
309− testWidget' checkStatic checkHydrated $ void $ inputElement $ def
310− & inputElementConfig_initialValue .~ "test"
311− it "updates value attribute at postBuild" $ runWD $ do
312− let checkStatic = do
313− e <- findElemWithRetry $ WD.ByTag "input"
314− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
316− checkHydrated e = do
317− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
318− testWidget' checkStatic checkHydrated $ do
320− _ <- inputElement $ def
321− & inputElementConfig_initialValue .~ "test"
322− & inputElementConfig_setValue .~ ("test-updated" <$ pb)
324− it "sets checked attr appropriately" $ runWD $ do
325− setCheckedChan <- liftIO newChan
326− let checkStatic = do
327− e <- findElemWithRetry $ WD.ByTag "input"
328− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
331− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
333− WD.click e -- Click to uncheck
334− WD.attr e "checked" `shouldBeWithRetryM` Nothing
335− liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
336− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
337− testWidget' checkStatic checkValue $ do
338− setChecked <- triggerEventWithChan setCheckedChan
339− _ <- inputElement $ def
340− & initialAttributes .~ "type" =: "checkbox"
341− & inputElementConfig_initialChecked .~ True
342− & inputElementConfig_setChecked .~ setChecked
344− it "sets checked attr appropriately at postbuild" $ runWD $ do
345− let checkStatic = do
346− e <- findElemWithRetry $ WD.ByTag "input"
347− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
350− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351− testWidget' checkStatic checkValue $ do
353− _ <- inputElement $ def
354− & initialAttributes .~ "type" =: "checkbox"
355− & inputElementConfig_initialChecked .~ False
356− & inputElementConfig_setChecked .~ (True <$ pb)
358− describe "hydration" $ do
359 it "doesn't wipe user input when switching over" $ runWD $ do
273 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
274+ inputRef <- newRef ("" :: Text)
361 testWidget'
275 testWidget'
363− e <- findElemWithRetry $ WD.ByTag "input"
277+ e <- WD.findElem $ WD.ByTag "input"
364− WD.sendKeys "world" e
278+ WD.sendKeys "hello world" e
366 (\e -> do
280 (\e -> do
367− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
281+ t <- WD.attr e "value"
282+ t `shouldBe` Just "hello world"
368− WD.click =<< findElemWithRetry (WD.ByTag "button")
283+ WD.click <=< WD.findElem $ WD.ByTag "button"
369− readRef inputRef `shouldBeWithRetryM` "hello world"
284+ input <- liftIO $ readRef inputRef
285+ input `shouldBe` "hello world"
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
287+ e <- inputElement def
372 click <- button "save"
288 click <- button "save"
373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
289 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374 it "captures user input after switchover" $ runWD $ do
290 it "captures user input after switchover" $ runWD $ do
375 inputRef <- newRef ("" :: Text)
291 inputRef <- newRef ("" :: Text)
376 let checkValue = do
292 let checkValue = do
377− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
293+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
378− WD.click =<< findElemWithRetry (WD.ByTag "button")
294+ WD.click <=< WD.findElem $ WD.ByTag "button"
379− readRef inputRef `shouldBeWithRetryM` "hello world"
295+ input <- liftIO $ readRef inputRef
296+ input `shouldBe` "hello world"
380 testWidget (pure ()) checkValue $ do
297 testWidget (pure ()) checkValue $ do
381 e <- inputElement def
298 e <- inputElement def
382 click <- button "save"
299 click <- button "save"
@@ -384,21 +301,23 @@ tests withDebugging wdConfig caps _selenium = do
384 it "sets focus appropriately" $ runWD $ do
301 it "sets focus appropriately" $ runWD $ do
385 focusRef <- newRef False
302 focusRef <- newRef False
386 let checkValue = do
303 let checkValue = do
387− readRef focusRef `shouldBeWithRetryM` False
304+ readRef focusRef >>= flip shouldBe False
388− e <- findElemWithRetry $ WD.ByTag "input"
305+ e <- WD.findElem $ WD.ByTag "input"
389 WD.click e
306 WD.click e
307+ liftIO $ threadDelay 100000
390− readRef focusRef `shouldBeWithRetryM` True
308+ readRef focusRef >>= flip shouldBe True
391 testWidget (pure ()) checkValue $ do
309 testWidget (pure ()) checkValue $ do
392 e <- inputElement def
310 e <- inputElement def
393 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
311 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
394 it "sets focus when focus occurs before hydration" $ runWD $ do
312 it "sets focus when focus occurs before hydration" $ runWD $ do
395 focusRef <- newRef False
313 focusRef <- newRef False
396 let setup = do
314 let setup = do
397− e <- findElemWithRetry $ WD.ByTag "input"
315+ e <- WD.findElem $ WD.ByTag "input"
398 WD.click e
316 WD.click e
399− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
317+ hasFocus <- (== e) <$> WD.activeElem
318+ hasFocus `shouldBe` True
400− readRef focusRef `shouldBeWithRetryM` False
319+ readRef focusRef >>= flip shouldBe False
401− check = readRef focusRef `shouldBeWithRetryM` True
320+ check = readRef focusRef >>= flip shouldBe True
402 testWidget setup check $ do
321 testWidget setup check $ do
403 e <- inputElement def
322 e <- inputElement def
404 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
323 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -407,15 +326,17 @@ tests withDebugging wdConfig caps _selenium = do
407 valueRef <- newRef ("" :: Text)
326 valueRef <- newRef ("" :: Text)
408 setValueChan :: Chan Text <- liftIO newChan
327 setValueChan :: Chan Text <- liftIO newChan
409 let checkValue = do
328 let checkValue = do
410− readRef valueByUIRef `shouldBeWithRetryM` ""
329+ readRef valueByUIRef >>= flip shouldBe ""
411− readRef valueRef `shouldBeWithRetryM` ""
330+ readRef valueRef >>= flip shouldBe ""
412− e <- findElemWithRetry $ WD.ByTag "input"
331+ e <- WD.findElem $ WD.ByTag "input"
413 WD.sendKeys "hello" e
332 WD.sendKeys "hello" e
333+ liftIO $ threadDelay 100000
414− readRef valueByUIRef `shouldBeWithRetryM` "hello"
334+ readRef valueByUIRef >>= flip shouldBe "hello"
415− readRef valueRef `shouldBeWithRetryM` "hello"
335+ readRef valueRef >>= flip shouldBe "hello"
416 liftIO $ writeChan setValueChan "world"
336 liftIO $ writeChan setValueChan "world"
337+ liftIO $ threadDelay 100000
417− readRef valueByUIRef `shouldBeWithRetryM` "hello"
338+ readRef valueByUIRef >>= flip shouldBe "hello"
418− readRef valueRef `shouldBeWithRetryM` "world"
339+ readRef valueRef >>= flip shouldBe "world"
419 testWidget (pure ()) checkValue $ do
340 testWidget (pure ()) checkValue $ do
420 update <- triggerEventWithChan setValueChan
341 update <- triggerEventWithChan setValueChan
421 e <- inputElement $ def & inputElementConfig_setValue .~ update
342 e <- inputElement $ def & inputElementConfig_setValue .~ update
@@ -425,181 +346,51 @@ tests withDebugging wdConfig caps _selenium = do
425 checkedByUIRef <- newRef False
346 checkedByUIRef <- newRef False
426 checkedRef <- newRef False
347 checkedRef <- newRef False
427 setCheckedChan <- liftIO newChan
348 setCheckedChan <- liftIO newChan
428− let checkStatic = do
349+ let checkValue = do
350+ readRef checkedByUIRef >>= flip shouldBe False
351+ readRef checkedRef >>= flip shouldBe False
429− e <- findElemWithRetry $ WD.ByTag "input"
352+ e <- WD.findElem $ WD.ByTag "input"
430− WD.attr e "checked" `shouldBeWithRetryM` Nothing
433− readRef checkedByUIRef `shouldBeWithRetryM` False
434− readRef checkedRef `shouldBeWithRetryM` False
435− WD.attr e "checked" `shouldBeWithRetryM` Nothing
436 WD.moveToCenter e
353 WD.moveToCenter e
437 WD.click e
354 WD.click e
355+ liftIO $ threadDelay 100000
438− readRef checkedByUIRef `shouldBeWithRetryM` True
356+ readRef checkedByUIRef >>= flip shouldBe True
439− readRef checkedRef `shouldBeWithRetryM` True
357+ readRef checkedRef >>= flip shouldBe True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
441 liftIO $ writeChan setCheckedChan False
358 liftIO $ writeChan setCheckedChan False
359+ liftIO $ threadDelay 100000
442− readRef checkedByUIRef `shouldBeWithRetryM` True
360+ readRef checkedByUIRef >>= flip shouldBe True
443− readRef checkedRef `shouldBeWithRetryM` False
361+ readRef checkedRef >>= flip shouldBe False
444− WD.attr e "checked" `shouldBeWithRetryM` Nothing
445− testWidget' checkStatic checkValue $ do
362+ testWidget (pure ()) checkValue $ do
446 setChecked <- triggerEventWithChan setCheckedChan
363 setChecked <- triggerEventWithChan setCheckedChan
447 e <- inputElement $ def
364 e <- inputElement $ def
448 & initialAttributes .~ "type" =: "checkbox"
365 & initialAttributes .~ "type" =: "checkbox"
449 & inputElementConfig_setChecked .~ setChecked
366 & inputElementConfig_setChecked .~ setChecked
450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
367 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
368 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
452− it "respects user updates to checked which happen before hydration" $ runWD $ do
453− checkedByUIRef <- newRef False
454− checkedRef <- newRef False
455− let checkStatic = do
456− e <- findElemWithRetry $ WD.ByTag "input"
457− WD.attr e "checked" `shouldBeWithRetryM` Nothing
460− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
463− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
464− readRef checkedByUIRef `shouldBeWithRetryM` True
465− readRef checkedRef `shouldBeWithRetryM` True
466− testWidget' checkStatic checkValue $ do
467− e <- inputElement $ def
468− & initialAttributes .~ "type" =: "checkbox"
469− performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
470− performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
471 it "captures file uploads" $ runWD $ do
369 it "captures file uploads" $ runWD $ do
472 filesRef :: IORef [Text] <- newRef []
370 filesRef :: IORef [Text] <- newRef []
473 let uploadFile = do
371 let uploadFile = do
474− e <- findElemWithRetry $ WD.ByTag "input"
372+ e <- WD.findElem $ WD.ByTag "input"
475 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
373 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
476 WD.sendKeys (T.pack path) e
374 WD.sendKeys (T.pack path) e
477− WD.click =<< findElemWithRetry (WD.ByTag "button")
375+ WD.click <=< WD.findElem $ WD.ByTag "button"
478 liftIO $ removeFile path
376 liftIO $ removeFile path
377+ input <- readRef filesRef
479− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
378+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
480 testWidget (pure ()) uploadFile $ do
379 testWidget (pure ()) uploadFile $ do
481 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
380 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
482 click <- button "save"
381 click <- button "save"
483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
382 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484 names <- liftJSM $ traverse File.getName fs
383 names <- liftJSM $ traverse File.getName fs
485 liftIO $ writeRef filesRef names
384 liftIO $ writeRef filesRef names
486− it "fires _input event if the user altered the value before hydration" $ runWD $ do
385+
487− input <- newRef ("" :: Text)
488− update <- newRef ("" :: Text)
489− let checkStatic = do
490− e <- findElemWithRetry $ WD.ByTag "input"
491− WD.attr e "value" `shouldBeWithRetryM` Just ""
492− WD.sendKeys "test" e
493− WD.attr e "value" `shouldBeWithRetryM` Just "test"
495− checkHydrated e = do
496− WD.attr e "value" `shouldBeWithRetryM` Just "test"
497− readRef input `shouldBeWithRetryM` "test"
498− readRef update `shouldBeWithRetryM` "test"
499− testWidget' checkStatic checkHydrated $ do
500− e <- inputElement def
501− performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
502− performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
503− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
504− input <- newRef (Nothing :: Maybe Text)
505− let checkStatic = do
506− e <- findElemWithRetry $ WD.ByTag "input"
507− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
509− checkHydrated e = do
510− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
511− readRef input `shouldBeWithRetryM` Nothing
512− testWidget' checkStatic checkHydrated $ do
514− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
515− performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
516− it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
518− input <- findElemWithRetry $ WD.ByTag "input"
519− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
520− p <- findElemWithRetry (WD.ByTag "p")
521− shouldContainText "pb" p
522− testWidget checkBoth checkBoth $ do
524− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
525− el "p" $ dynText $ _inputElement_value e
526− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
527− let checkStatic = do
528− input <- findElemWithRetry $ WD.ByTag "input"
529− h2_value <- findElemWithRetry (WD.ByTag "h2")
530− h3_input <- findElemWithRetry (WD.ByTag "h3")
531− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
532− shouldContainText "pb" h2_value
533− shouldContainText "" h3_input
534− WD.sendKeys "abc" input
535− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
536− shouldContainText "pb" h2_value
537− shouldContainText "" h3_input
538− pure (input, h2_value, h3_input)
539− checkHydrated (input, h2_value, h3_input) = do
540− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
541− shouldContainText "pbabc" h3_input
542− shouldContainText "pbabc pb" h2_value
544− testWidget' checkStatic checkHydrated $ do
546− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
547− el "h1" $ dynText $ _inputElement_value e
548− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
549− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
550− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
551− let checkStatic = do
552− input <- findElemWithRetry $ WD.ByTag "input"
553− p <- findElemWithRetry (WD.ByTag "p")
554− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
555− shouldContainText "pb" p
556− WD.sendKeys "abc" input
557− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
558− shouldContainText "pb" p -- It won't be updated yet
560− checkHydrated (input, p) = do
561− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
562− shouldContainText "pbabc" p
564− testWidget' checkStatic checkHydrated $ do
566− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
567− el "p" $ dynText $ _inputElement_value e
568− it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
569− valRef <- newRef ([] :: [Text])
570− inputRef <- newRef ([] :: [Text])
571− let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
573− input <- findElemWithRetry $ WD.ByTag "input"
574− p <- findElemWithRetry (WD.ByTag "p")
575− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
576− shouldContainText "pb" p
577− WD.sendKeys "abc" input
578− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
579− shouldContainText "pb" p -- It won't be updated yet
580− readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
581− readRef valRef `shouldBeWithRetryM` ["pb"]
583− checkHydrated (input, p) = do
584− readRef inputRef `shouldBeWithRetryM` ["pbabc"]
585− readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
586− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
587− shouldContainText "pbabc" p
589− testWidget' checkStatic checkHydrated $ do
590− liftIO $ writeRef valRef []
592− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
593− el "p" $ dynText $ _inputElement_value e
594− performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
595− performEvent_ $ consRef inputRef <$> _inputElement_input e
596− describe "hydration/immediate" $ do
386+ describe "hydration/immediate" $ session' $ do
597 it "captures user input after switchover" $ runWD $ do
387 it "captures user input after switchover" $ runWD $ do
598 inputRef :: IORef Text <- newRef ""
388 inputRef :: IORef Text <- newRef ""
599 let checkValue = do
389 let checkValue = do
600− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
390+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
601− WD.click =<< findElemWithRetry (WD.ByTag "button")
391+ WD.click <=< WD.findElem $ WD.ByTag "button"
602− readRef inputRef `shouldBeWithRetryM` "hello world"
392+ input <- readRef inputRef
393+ input `shouldBe` "hello world"
603 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
394 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
604 e <- inputElement def
395 e <- inputElement def
605 click <- button "save"
396 click <- button "save"
@@ -607,10 +398,11 @@ tests withDebugging wdConfig caps _selenium = do
607 it "sets focus appropriately" $ runWD $ do
398 it "sets focus appropriately" $ runWD $ do
608 focusRef <- newRef False
399 focusRef <- newRef False
609 let checkValue = do
400 let checkValue = do
610− readRef focusRef `shouldBeWithRetryM` False
401+ readRef focusRef >>= flip shouldBe False
611− e <- findElemWithRetry $ WD.ByTag "input"
402+ e <- WD.findElem $ WD.ByTag "input"
612 WD.click e
403 WD.click e
404+ liftIO $ threadDelay 100000
613− readRef focusRef `shouldBeWithRetryM` True
405+ readRef focusRef >>= flip shouldBe True
614 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
406 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
615 e <- inputElement def
407 e <- inputElement def
616 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
408 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -619,15 +411,17 @@ tests withDebugging wdConfig caps _selenium = do
619 valueRef :: IORef Text <- newRef ""
411 valueRef :: IORef Text <- newRef ""
620 setValueChan :: Chan Text <- liftIO newChan
412 setValueChan :: Chan Text <- liftIO newChan
621 let checkValue = do
413 let checkValue = do
622− readRef valueByUIRef `shouldBeWithRetryM` ""
414+ readRef valueByUIRef >>= flip shouldBe ""
623− readRef valueRef `shouldBeWithRetryM` ""
415+ readRef valueRef >>= flip shouldBe ""
624− e <- findElemWithRetry $ WD.ByTag "input"
416+ e <- WD.findElem $ WD.ByTag "input"
625 WD.sendKeys "hello" e
417 WD.sendKeys "hello" e
418+ liftIO $ threadDelay 100000
626− readRef valueByUIRef `shouldBeWithRetryM` "hello"
419+ readRef valueByUIRef >>= flip shouldBe "hello"
627− readRef valueRef `shouldBeWithRetryM` "hello"
420+ readRef valueRef >>= flip shouldBe "hello"
628 liftIO $ writeChan setValueChan "world"
421 liftIO $ writeChan setValueChan "world"
422+ liftIO $ threadDelay 100000
629− readRef valueByUIRef `shouldBeWithRetryM` "hello"
423+ readRef valueByUIRef >>= flip shouldBe "hello"
630− readRef valueRef `shouldBeWithRetryM` "world"
424+ readRef valueRef >>= flip shouldBe "world"
631 testWidget (pure ()) checkValue $ do
425 testWidget (pure ()) checkValue $ do
632 update <- triggerEventWithChan setValueChan
426 update <- triggerEventWithChan setValueChan
633 prerender_ (pure ()) $ do
427 prerender_ (pure ()) $ do
@@ -639,16 +433,18 @@ tests withDebugging wdConfig caps _selenium = do
639 checkedRef <- newRef False
433 checkedRef <- newRef False
640 setCheckedChan <- liftIO newChan
434 setCheckedChan <- liftIO newChan
641 let checkValue = do
435 let checkValue = do
642− readRef checkedByUIRef `shouldBeWithRetryM` False
436+ readRef checkedByUIRef >>= flip shouldBe False
643− readRef checkedRef `shouldBeWithRetryM` False
437+ readRef checkedRef >>= flip shouldBe False
644− e <- findElemWithRetry $ WD.ByTag "input"
438+ e <- WD.findElem $ WD.ByTag "input"
645 WD.moveToCenter e
439 WD.moveToCenter e
646 WD.click e
440 WD.click e
441+ liftIO $ threadDelay 100000
647− readRef checkedByUIRef `shouldBeWithRetryM` True
442+ readRef checkedByUIRef >>= flip shouldBe True
648− readRef checkedRef `shouldBeWithRetryM` True
443+ readRef checkedRef >>= flip shouldBe True
649 liftIO $ writeChan setCheckedChan False
444 liftIO $ writeChan setCheckedChan False
445+ liftIO $ threadDelay 100000
650− readRef checkedByUIRef `shouldBeWithRetryM` True
446+ readRef checkedByUIRef >>= flip shouldBe True
651− readRef checkedRef `shouldBeWithRetryM` False
447+ readRef checkedRef >>= flip shouldBe False
652 testWidget (pure ()) checkValue $ do
448 testWidget (pure ()) checkValue $ do
653 setChecked <- triggerEventWithChan setCheckedChan
449 setChecked <- triggerEventWithChan setCheckedChan
654 prerender_ (pure ()) $ do
450 prerender_ (pure ()) $ do
@@ -660,12 +456,13 @@ tests withDebugging wdConfig caps _selenium = do
660 it "captures file uploads" $ runWD $ do
456 it "captures file uploads" $ runWD $ do
661 filesRef :: IORef [Text] <- newRef []
457 filesRef :: IORef [Text] <- newRef []
662 let uploadFile = do
458 let uploadFile = do
663− e <- findElemWithRetry $ WD.ByTag "input"
459+ e <- WD.findElem $ WD.ByTag "input"
664 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
460 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
665 WD.sendKeys (T.pack path) e
461 WD.sendKeys (T.pack path) e
666− WD.click =<< findElemWithRetry (WD.ByTag "button")
462+ WD.click <=< WD.findElem $ WD.ByTag "button"
667 liftIO $ removeFile path
463 liftIO $ removeFile path
464+ input <- liftIO $ readRef filesRef
668− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
465+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
669 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
466 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
670 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
467 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
671 click <- button "save"
468 click <- button "save"
@@ -673,42 +470,21 @@ tests withDebugging wdConfig caps _selenium = do
673 names <- liftJSM $ traverse File.getName fs
470 names <- liftJSM $ traverse File.getName fs
674 liftIO $ writeRef filesRef names
471 liftIO $ writeRef filesRef names
676− session' "textAreaElement" $ do
473+ describe "textAreaElement" $ do
677− describe "static renderer" $ do
678− it "sets value attribute" $ runWD $ do
679− let checkStatic = do
680− e <- findElemWithRetry $ WD.ByTag "textarea"
681− WD.attr e "value" `shouldBeWithRetryM` Just "test"
683− checkHydrated e = do
684− WD.attr e "value" `shouldBeWithRetryM` Just "test"
685− testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
686− & textAreaElementConfig_initialValue .~ "test"
687− it "updates value attribute at postBuild" $ runWD $ do
688− let checkStatic = do
689− e <- findElemWithRetry $ WD.ByTag "textarea"
690− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
692− checkHydrated e = do
693− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
694− testWidget' checkStatic checkHydrated $ do
696− _ <- textAreaElement $ def
697− & textAreaElementConfig_initialValue .~ "test"
698− & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
700− describe "hydration" $ do
474+ describe "hydration" $ session' $ do
701 it "doesn't wipe user input when switching over" $ runWD $ do
475 it "doesn't wipe user input when switching over" $ runWD $ do
702 inputRef <- newRef ("" :: Text)
476 inputRef <- newRef ("" :: Text)
703 testWidget'
477 testWidget'
705− e <- findElemWithRetry $ WD.ByTag "textarea"
479+ e <- WD.findElem $ WD.ByTag "textarea"
706 WD.sendKeys "hello world" e
480 WD.sendKeys "hello world" e
708 (\e -> do
482 (\e -> do
709− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
483+ t <- WD.attr e "value"
484+ t `shouldBe` Just "hello world"
710− WD.click <=< findElemWithRetry $ WD.ByTag "button"
485+ WD.click <=< WD.findElem $ WD.ByTag "button"
711− readRef inputRef `shouldBeWithRetryM` "hello world"
486+ input <- readRef inputRef
487+ input `shouldBe` "hello world"
713 e <- textAreaElement def
489 e <- textAreaElement def
714 click <- button "save"
490 click <- button "save"
@@ -716,9 +492,10 @@ tests withDebugging wdConfig caps _selenium = do
716 it "captures user input after switchover" $ runWD $ do
492 it "captures user input after switchover" $ runWD $ do
717 inputRef <- newRef ("" :: Text)
493 inputRef <- newRef ("" :: Text)
718 let checkValue = do
494 let checkValue = do
719− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")
495+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
720− WD.click =<< findElemWithRetry (WD.ByTag "button")
496+ WD.click <=< WD.findElem $ WD.ByTag "button"
721− readRef inputRef `shouldBeWithRetryM` "hello world"
497+ input <- readRef inputRef
498+ input `shouldBe` "hello world"
722 testWidget (pure ()) checkValue $ do
499 testWidget (pure ()) checkValue $ do
723 e <- textAreaElement def
500 e <- textAreaElement def
724 click <- button "save"
501 click <- button "save"
@@ -726,21 +503,23 @@ tests withDebugging wdConfig caps _selenium = do
726 it "sets focus appropriately" $ runWD $ do
503 it "sets focus appropriately" $ runWD $ do
727 focusRef <- newRef False
504 focusRef <- newRef False
728 let checkValue = do
505 let checkValue = do
729− readRef focusRef `shouldBeWithRetryM` False
506+ readRef focusRef >>= flip shouldBe False
730− e <- findElemWithRetry $ WD.ByTag "textarea"
507+ e <- WD.findElem $ WD.ByTag "textarea"
731 WD.click e
508 WD.click e
509+ liftIO $ threadDelay 100000
732− readRef focusRef `shouldBeWithRetryM` True
510+ readRef focusRef >>= flip shouldBe True
733 testWidget (pure ()) checkValue $ do
511 testWidget (pure ()) checkValue $ do
734 e <- textAreaElement def
512 e <- textAreaElement def
735 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
513 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
736 it "sets focus when focus occurs before hydration" $ runWD $ do
514 it "sets focus when focus occurs before hydration" $ runWD $ do
737 focusRef <- newRef False
515 focusRef <- newRef False
738 let setup = do
516 let setup = do
739− e <- findElemWithRetry $ WD.ByTag "textarea"
517+ e <- WD.findElem $ WD.ByTag "textarea"
740 WD.click e
518 WD.click e
741− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
519+ hasFocus <- (== e) <$> WD.activeElem
520+ hasFocus `shouldBe` True
742− readRef focusRef `shouldBeWithRetryM` False
521+ readRef focusRef >>= flip shouldBe False
743− check = readRef focusRef `shouldBeWithRetryM` True
522+ check = readRef focusRef >>= flip shouldBe True
744 testWidget setup check $ do
523 testWidget setup check $ do
745 e <- textAreaElement def
524 e <- textAreaElement def
746 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
525 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -749,110 +528,31 @@ tests withDebugging wdConfig caps _selenium = do
749 valueRef <- newRef ("" :: Text)
528 valueRef <- newRef ("" :: Text)
750 setValueChan :: Chan Text <- liftIO newChan
529 setValueChan :: Chan Text <- liftIO newChan
751 let checkValue = do
530 let checkValue = do
752− readRef valueByUIRef `shouldBeWithRetryM` ""
531+ readRef valueByUIRef >>= flip shouldBe ""
753− readRef valueRef `shouldBeWithRetryM` ""
532+ readRef valueRef >>= flip shouldBe ""
754− e <- findElemWithRetry $ WD.ByTag "textarea"
533+ e <- WD.findElem $ WD.ByTag "textarea"
755 WD.sendKeys "hello" e
534 WD.sendKeys "hello" e
535+ liftIO $ threadDelay 100000
756− readRef valueByUIRef `shouldBeWithRetryM` "hello"
536+ readRef valueByUIRef >>= flip shouldBe "hello"
757− readRef valueRef `shouldBeWithRetryM` "hello"
537+ readRef valueRef >>= flip shouldBe "hello"
758 liftIO $ writeChan setValueChan "world"
538 liftIO $ writeChan setValueChan "world"
539+ liftIO $ threadDelay 100000
759− readRef valueByUIRef `shouldBeWithRetryM` "hello"
540+ readRef valueByUIRef >>= flip shouldBe "hello"
760− readRef valueRef `shouldBeWithRetryM` "world"
541+ readRef valueRef >>= flip shouldBe "world"
761 testWidget (pure ()) checkValue $ do
542 testWidget (pure ()) checkValue $ do
762 setValue' <- triggerEventWithChan setValueChan
543 setValue' <- triggerEventWithChan setValueChan
763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
544 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
545 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
546 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
766− it "fires _input event if the user altered the value before hydration" $ runWD $ do
767− textarea <- newRef ("" :: Text)
768− update <- newRef ("" :: Text)
769− let checkStatic = do
770− e <- findElemWithRetry $ WD.ByTag "textarea"
771− WD.attr e "value" `shouldBeWithRetryM` Just ""
772− WD.sendKeys "test" e
773− WD.attr e "value" `shouldBeWithRetryM` Just "test"
775− checkHydrated e = do
776− WD.attr e "value" `shouldBeWithRetryM` Just "test"
777− readRef textarea `shouldBeWithRetryM` "test"
778− readRef update `shouldBeWithRetryM` "test"
779− testWidget' checkStatic checkHydrated $ do
780− e <- textAreaElement def
781− performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
782− performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
783− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
784− textarea <- newRef (Nothing :: Maybe Text)
785− let checkStatic = do
786− e <- findElemWithRetry $ WD.ByTag "textarea"
787− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
789− checkHydrated e = do
790− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
791− readRef textarea `shouldBeWithRetryM` Nothing
792− testWidget' checkStatic checkHydrated $ do
794− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
795− performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
796− it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
798− textarea <- findElemWithRetry $ WD.ByTag "textarea"
799− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
800− p <- findElemWithRetry (WD.ByTag "p")
801− shouldContainText "pb" p
802− testWidget checkBoth checkBoth $ do
804− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
805− el "p" $ dynText $ _textAreaElement_value e
806− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
807− let checkStatic = do
808− textarea <- findElemWithRetry $ WD.ByTag "textarea"
809− h2_value <- findElemWithRetry (WD.ByTag "h2")
810− h3_input <- findElemWithRetry (WD.ByTag "h3")
811− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
812− shouldContainText "pb" h2_value
813− shouldContainText "" h3_input
814− WD.sendKeys "abc" textarea
815− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
816− shouldContainText "pb" h2_value
817− shouldContainText "" h3_input
818− pure (textarea, h2_value, h3_input)
819− checkHydrated (textarea, h2_value, h3_input) = do
820− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
821− shouldContainText "pbabc" h3_input
822− shouldContainText "pbabc pb" h2_value
824− testWidget' checkStatic checkHydrated $ do
826− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
827− el "h1" $ dynText $ _textAreaElement_value e
828− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
829− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
830− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
831− let checkStatic = do
832− textarea <- findElemWithRetry $ WD.ByTag "textarea"
833− p <- findElemWithRetry (WD.ByTag "p")
834− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
835− shouldContainText "pb" p
836− WD.sendKeys "abc" textarea
837− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
838− shouldContainText "pb" p -- It won't be updated yet
840− checkHydrated (textarea, p) = do
841− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
842− shouldContainText "pbabc" p
844− testWidget' checkStatic checkHydrated $ do
846− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
847− el "p" $ dynText $ _textAreaElement_value e
849− describe "hydration/immediate" $ do
548+ describe "hydration/immediate" $ session' $ do
850 it "captures user input after switchover" $ runWD $ do
549 it "captures user input after switchover" $ runWD $ do
851 inputRef :: IORef Text <- newRef ""
550 inputRef :: IORef Text <- newRef ""
852 let checkValue = do
551 let checkValue = do
853− WD.sendKeys "hello world" <=< findElemWithRetry $ WD.ByTag "textarea"
552+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
854− WD.click <=< findElemWithRetry $ WD.ByTag "button"
553+ WD.click <=< WD.findElem $ WD.ByTag "button"
855− readRef inputRef `shouldBeWithRetryM` "hello world"
554+ input <- liftIO $ readRef inputRef
555+ input `shouldBe` "hello world"
856 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
556 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
857 e <- textAreaElement def
557 e <- textAreaElement def
858 click <- button "save"
558 click <- button "save"
@@ -860,10 +560,11 @@ tests withDebugging wdConfig caps _selenium = do
860 it "sets focus appropriately" $ runWD $ do
560 it "sets focus appropriately" $ runWD $ do
861 focusRef <- newRef False
561 focusRef <- newRef False
862 let checkValue = do
562 let checkValue = do
863− readRef focusRef `shouldBeWithRetryM` False
563+ readRef focusRef >>= flip shouldBe False
864− e <- findElemWithRetry $ WD.ByTag "textarea"
564+ e <- WD.findElem $ WD.ByTag "textarea"
865 WD.click e
565 WD.click e
566+ liftIO $ threadDelay 100000
866− readRef focusRef `shouldBeWithRetryM` True
567+ readRef focusRef >>= flip shouldBe True
867 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
568 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
868 e <- textAreaElement def
569 e <- textAreaElement def
869 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
570 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -872,15 +573,17 @@ tests withDebugging wdConfig caps _selenium = do
872 valueRef :: IORef Text <- newRef ""
573 valueRef :: IORef Text <- newRef ""
873 setValueChan :: Chan Text <- liftIO newChan
574 setValueChan :: Chan Text <- liftIO newChan
874 let checkValue = do
575 let checkValue = do
875− readRef valueByUIRef `shouldBeWithRetryM` ""
576+ readRef valueByUIRef >>= flip shouldBe ""
876− readRef valueRef `shouldBeWithRetryM` ""
577+ readRef valueRef >>= flip shouldBe ""
877− e <- findElemWithRetry $ WD.ByTag "textarea"
578+ e <- WD.findElem $ WD.ByTag "textarea"
878 WD.sendKeys "hello" e
579 WD.sendKeys "hello" e
580+ liftIO $ threadDelay 100000
879− readRef valueByUIRef `shouldBeWithRetryM` "hello"
581+ readRef valueByUIRef >>= flip shouldBe "hello"
880− readRef valueRef `shouldBeWithRetryM` "hello"
582+ readRef valueRef >>= flip shouldBe "hello"
881 liftIO $ writeChan setValueChan "world"
583 liftIO $ writeChan setValueChan "world"
584+ liftIO $ threadDelay 100000
882− readRef valueByUIRef `shouldBeWithRetryM` "hello"
585+ readRef valueByUIRef >>= flip shouldBe "hello"
883− readRef valueRef `shouldBeWithRetryM` "world"
586+ readRef valueRef >>= flip shouldBe "world"
884 testWidget (pure ()) checkValue $ do
587 testWidget (pure ()) checkValue $ do
885 setValue' <- triggerEventWithChan setValueChan
588 setValue' <- triggerEventWithChan setValueChan
886 prerender_ (pure ()) $ do
589 prerender_ (pure ()) $ do
@@ -888,26 +591,26 @@ tests withDebugging wdConfig caps _selenium = do
888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
591 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
592 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
891− session' "selectElement" $ do
594+ describe "selectElement" $ do
892 let options :: DomBuilder t m => m ()
595 let options :: DomBuilder t m => m ()
893 options = do
596 options = do
894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
597 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
598 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
599 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
600+ describe "hydration" $ session' $ do
898 it "sets initial value correctly" $ runWD $ do
601 it "sets initial value correctly" $ runWD $ do
899 inputRef <- newRef ("" :: Text)
602 inputRef <- newRef ("" :: Text)
900 let setup = do
603 let setup = do
901− e <- findElemWithRetry $ WD.ByTag "select"
604+ e <- WD.findElem $ WD.ByTag "select"
902 assertAttr e "value" (Just "three")
605 assertAttr e "value" (Just "three")
903− WD.click =<< findElemWithRetry (WD.ById "two")
606+ WD.click <=< WD.findElem $ WD.ById "two"
905 check e = do
608 check e = do
906 assertAttr e "value" (Just "two")
609 assertAttr e "value" (Just "two")
907− readRef inputRef `shouldBeWithRetryM` "three"
610+ readRef inputRef >>= (`shouldBe` "three")
908− WD.click =<< findElemWithRetry (WD.ByTag "button")
611+ WD.click <=< WD.findElem $ WD.ByTag "button"
909 assertAttr e "value" (Just "two")
612 assertAttr e "value" (Just "two")
910− readRef inputRef `shouldBeWithRetryM` "two"
613+ readRef inputRef >>= (`shouldBe` "two")
911 testWidget' setup check $ do
614 testWidget' setup check $ do
912 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
615 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
913 click <- button "save"
616 click <- button "save"
@@ -916,12 +619,12 @@ tests withDebugging wdConfig caps _selenium = do
916 it "captures user input after switchover" $ runWD $ do
619 it "captures user input after switchover" $ runWD $ do
917 inputRef <- newRef ("" :: Text)
620 inputRef <- newRef ("" :: Text)
918 let checkValue = do
621 let checkValue = do
919− e <- findElemWithRetry $ WD.ByTag "select"
622+ e <- WD.findElem $ WD.ByTag "select"
920 assertAttr e "value" (Just "one")
623 assertAttr e "value" (Just "one")
921− WD.click =<< findElemWithRetry (WD.ById "two")
624+ WD.click <=< WD.findElem $ WD.ById "two"
922 assertAttr e "value" (Just "two")
625 assertAttr e "value" (Just "two")
923− WD.click =<< findElemWithRetry (WD.ByTag "button")
626+ WD.click <=< WD.findElem $ WD.ByTag "button"
924− readRef inputRef `shouldBeWithRetryM` "two"
627+ readRef inputRef >>= (`shouldBe` "two")
925 testWidget (pure ()) checkValue $ do
628 testWidget (pure ()) checkValue $ do
926 (e, ()) <- selectElement def options
629 (e, ()) <- selectElement def options
927 click <- button "save"
630 click <- button "save"
@@ -929,21 +632,23 @@ tests withDebugging wdConfig caps _selenium = do
929 it "sets focus appropriately" $ runWD $ do
632 it "sets focus appropriately" $ runWD $ do
930 focusRef <- newRef False
633 focusRef <- newRef False
931 let checkValue = do
634 let checkValue = do
932− readRef focusRef `shouldBeWithRetryM` False
635+ readRef focusRef >>= flip shouldBe False
933− e <- findElemWithRetry $ WD.ByTag "select"
636+ e <- WD.findElem $ WD.ByTag "select"
934 WD.click e
637 WD.click e
638+ liftIO $ threadDelay 100000
935− readRef focusRef `shouldBeWithRetryM` True
639+ readRef focusRef >>= flip shouldBe True
936 testWidget (pure ()) checkValue $ do
640 testWidget (pure ()) checkValue $ do
937 (e, ()) <- selectElement def options
641 (e, ()) <- selectElement def options
938 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
642 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
939 it "sets focus when focus occurs before hydration" $ runWD $ do
643 it "sets focus when focus occurs before hydration" $ runWD $ do
940 focusRef <- newRef False
644 focusRef <- newRef False
941 let setup = do
645 let setup = do
942− e <- findElemWithRetry $ WD.ByTag "select"
646+ e <- WD.findElem $ WD.ByTag "select"
943 WD.click e
647 WD.click e
944− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
648+ hasFocus <- (== e) <$> WD.activeElem
649+ hasFocus `shouldBe` True
945− readRef focusRef `shouldBeWithRetryM` False
650+ readRef focusRef >>= flip shouldBe False
946− check = readRef focusRef `shouldBeWithRetryM` True
651+ check = readRef focusRef >>= flip shouldBe True
947 testWidget setup check $ do
652 testWidget setup check $ do
948 (e, ()) <- selectElement def options
653 (e, ()) <- selectElement def options
949 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
654 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
@@ -952,29 +657,31 @@ tests withDebugging wdConfig caps _selenium = do
952 valueRef <- newRef ("" :: Text)
657 valueRef <- newRef ("" :: Text)
953 setValueChan :: Chan Text <- liftIO newChan
658 setValueChan :: Chan Text <- liftIO newChan
954 let checkValue = do
659 let checkValue = do
955− e <- findElemWithRetry $ WD.ByTag "select"
660+ e <- WD.findElem $ WD.ByTag "select"
956 assertAttr e "value" (Just "one")
661 assertAttr e "value" (Just "one")
957− readRef valueByUIRef `shouldBeWithRetryM` "one"
662+ readRef valueByUIRef >>= flip shouldBe "one"
958− readRef valueRef `shouldBeWithRetryM` "one"
663+ readRef valueRef >>= flip shouldBe "one"
959− WD.click <=< findElemWithRetry $ WD.ById "two"
664+ WD.click <=< WD.findElem $ WD.ById "two"
665+ liftIO $ threadDelay 100000
960− readRef valueByUIRef `shouldBeWithRetryM` "two"
666+ readRef valueByUIRef >>= flip shouldBe "two"
961− readRef valueRef `shouldBeWithRetryM` "two"
667+ readRef valueRef >>= flip shouldBe "two"
962 liftIO $ writeChan setValueChan "three"
668 liftIO $ writeChan setValueChan "three"
669+ liftIO $ threadDelay 100000
963− readRef valueByUIRef `shouldBeWithRetryM` "two"
670+ readRef valueByUIRef >>= flip shouldBe "two"
964− readRef valueRef `shouldBeWithRetryM` "three"
671+ readRef valueRef >>= flip shouldBe "three"
965 testWidget (pure ()) checkValue $ do
672 testWidget (pure ()) checkValue $ do
966 setValue' <- triggerEventWithChan setValueChan
673 setValue' <- triggerEventWithChan setValueChan
967 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
674 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
675 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
676 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
971− describe "hydration/immediate" $ do
678+ describe "hydration/immediate" $ session' $ do
972 it "captures user input after switchover" $ runWD $ do
679 it "captures user input after switchover" $ runWD $ do
973 inputRef :: IORef Text <- newRef ""
680 inputRef :: IORef Text <- newRef ""
974 let checkValue = do
681 let checkValue = do
975− WD.click <=< findElemWithRetry $ WD.ById "two"
682+ WD.click <=< WD.findElem $ WD.ById "two"
976− WD.click <=< findElemWithRetry $ WD.ByTag "button"
683+ WD.click <=< WD.findElem $ WD.ByTag "button"
977− readRef inputRef `shouldBeWithRetryM` "two"
684+ readRef inputRef >>= flip shouldBe "two"
978 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
685 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
979 (e, ()) <- selectElement def options
686 (e, ()) <- selectElement def options
980 click <- button "save"
687 click <- button "save"
@@ -982,16 +689,17 @@ tests withDebugging wdConfig caps _selenium = do
982 it "sets focus appropriately" $ runWD $ do
689 it "sets focus appropriately" $ runWD $ do
983 focusRef <- newRef False
690 focusRef <- newRef False
984 let checkValue = do
691 let checkValue = do
985− readRef focusRef `shouldBeWithRetryM` False
692+ readRef focusRef >>= flip shouldBe False
986− e <- findElemWithRetry $ WD.ByTag "select"
693+ e <- WD.findElem $ WD.ByTag "select"
987 WD.click e
694 WD.click e
695+ liftIO $ threadDelay 100000
988− readRef focusRef `shouldBeWithRetryM` True
696+ readRef focusRef >>= flip shouldBe True
989 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
697 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
990 (e, ()) <- selectElement def options
698 (e, ()) <- selectElement def options
991 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
699 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
992 it "has correct initial value" $ runWD $ do
700 it "has correct initial value" $ runWD $ do
993 valueRef :: IORef Text <- newRef ""
701 valueRef :: IORef Text <- newRef ""
994− let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
702+ let checkValue = readRef valueRef >>= flip shouldBe "one"
995 testWidget (pure ()) checkValue $ do
703 testWidget (pure ()) checkValue $ do
996 prerender_ (pure ()) $ do
704 prerender_ (pure ()) $ do
997 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
705 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
@@ -1001,12 +709,14 @@ tests withDebugging wdConfig caps _selenium = do
1001 valueRef :: IORef Text <- newRef ""
709 valueRef :: IORef Text <- newRef ""
1002 setValueChan :: Chan Text <- liftIO newChan
710 setValueChan :: Chan Text <- liftIO newChan
1003 let checkValue = do
711 let checkValue = do
1004− WD.click =<< findElemWithRetry (WD.ById "two")
712+ WD.click <=< WD.findElem $ WD.ById "two"
713+ liftIO $ threadDelay 100000
1005− readRef valueByUIRef `shouldBeWithRetryM` "two"
714+ readRef valueByUIRef >>= flip shouldBe "two"
1006− readRef valueRef `shouldBeWithRetryM` "two"
715+ readRef valueRef >>= flip shouldBe "two"
1007 liftIO $ writeChan setValueChan "three"
716 liftIO $ writeChan setValueChan "three"
717+ liftIO $ threadDelay 100000
1008− readRef valueByUIRef `shouldBeWithRetryM` "two"
718+ readRef valueByUIRef >>= flip shouldBe "two"
1009− readRef valueRef `shouldBeWithRetryM` "three"
719+ readRef valueRef >>= flip shouldBe "three"
1010 testWidget (pure ()) checkValue $ do
720 testWidget (pure ()) checkValue $ do
1011 setValue' <- triggerEventWithChan setValueChan
721 setValue' <- triggerEventWithChan setValueChan
1012 prerender_ (pure ()) $ do
722 prerender_ (pure ()) $ do
@@ -1014,12 +724,12 @@ tests withDebugging wdConfig caps _selenium = do
1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
724 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
725 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1017− session' "prerender" $ do
727+ describe "prerender" $ session' $ do
1018 it "works in simple case" $ runWD $ do
728 it "works in simple case" $ runWD $ do
1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
729 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020 prerender_ (text "One") (text "Two")
730 prerender_ (text "One") (text "Two")
1021 it "removes element correctly" $ runWD $ do
731 it "removes element correctly" $ runWD $ do
1022− testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
732+ testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
1023 prerender_ (el "span" $ text "One") (text "Two")
733 prerender_ (el "span" $ text "One") (text "Two")
1024 it "can be nested in server widget" $ runWD $ do
734 it "can be nested in server widget" $ runWD $ do
1025 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
735 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
@@ -1037,15 +747,14 @@ tests withDebugging wdConfig caps _selenium = do
1037 it "works inside other element" $ runWD $ do
747 it "works inside other element" $ runWD $ do
1038 testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do
748 testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do
1039 el "div" $ prerender_ (text "One") (text "Two")
749 el "div" $ prerender_ (text "One") (text "Two")
1040−-- TODO re-enable this
1041−-- it "places fences and removes them" $ runWD $ do
750+ it "places fences and removes them" $ runWD $ do
1042−-- testWidget'
751+ testWidget'
1044−-- scripts <- WD.findElems $ WD.ByTag "script"
753+ scripts <- WD.findElems $ WD.ByTag "script"
1045−-- filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts
754+ filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts
1047−-- (traverse_ elementShouldBeRemoved)
756+ (traverse_ elementShouldBeRemoved)
1048−-- (el "span" $ prerender_ (text "One") (text "Two"))
757+ (el "span" $ prerender_ (text "One") (text "Two"))
1049 it "postBuild works on server side" $ runWD $ do
758 it "postBuild works on server side" $ runWD $ do
1050 lock :: MVar () <- liftIO newEmptyMVar
759 lock :: MVar () <- liftIO newEmptyMVar
1051 testWidget (liftIO $ takeMVar lock) (pure ()) $ do
760 testWidget (liftIO $ takeMVar lock) (pure ()) $ do
@@ -1059,9 +768,9 @@ tests withDebugging wdConfig caps _selenium = do
1059 pb <- getPostBuild
768 pb <- getPostBuild
1060 performEvent_ $ liftIO (putMVar lock ()) <$ pb
769 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1061 it "result Dynamic is updated *after* switchover" $ runWD $ do
770 it "result Dynamic is updated *after* switchover" $ runWD $ do
1062− let preSwitchover = checkBodyText "PostBuild"
771+ let static = shouldContainText "PostBuild" =<< WD.findElem (WD.ByTag "body")
1063− check = checkBodyText "Client"
772+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
1064− testWidget preSwitchover check $ void $ do
773+ testWidget static check $ void $ do
1065 d <- prerender (pure "Initial") (pure "Client")
774 d <- prerender (pure "Initial") (pure "Client")
1066 pb <- getPostBuild
775 pb <- getPostBuild
1067 initial <- sample $ current d
776 initial <- sample $ current d
@@ -1069,39 +778,32 @@ tests withDebugging wdConfig caps _selenium = do
1069 -- This essentially checks that the client IO runs *after* switchover/postBuild,
778 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1070 -- thus can't create conflicting DOM
779 -- thus can't create conflicting DOM
1071 it "can't exploit IO to break hydration" $ runWD $ do
780 it "can't exploit IO to break hydration" $ runWD $ do
1072− let preSwitchover = checkBodyText "Initial"
781+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
1073− testWidgetStatic preSwitchover $ void $ do
782+ testWidgetStatic static $ void $ do
1074 ref <- liftIO $ newRef "Initial"
783 ref <- liftIO $ newRef "Initial"
1075 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
784 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1076 text <=< liftIO $ readRef ref
785 text <=< liftIO $ readRef ref
1077 -- As above, so below
786 -- As above, so below
1078 it "can't exploit triggerEvent to break hydration" $ runWD $ do
787 it "can't exploit triggerEvent to break hydration" $ runWD $ do
1079− let preSwitchover = checkBodyText "Initial"
788+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
1080− check = checkBodyText "Client"
789+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
1081− testWidget preSwitchover check $ void $ do
790+ testWidget static check $ void $ do
1082 (e, trigger) <- newTriggerEvent
791 (e, trigger) <- newTriggerEvent
1083 prerender_ (pure ()) (liftIO $ trigger "Client")
792 prerender_ (pure ()) (liftIO $ trigger "Client")
1084 textNode $ TextNodeConfig "Initial" $ Just e
793 textNode $ TextNodeConfig "Initial" $ Just e
1086− session' "namespaces" $ do
1087− it "dyn can be nested in namespaced widget" $ runWD $ do
1088− testWidget (pure ()) (checkTextInTag "svg" "one") $ do
1089− let svgRootCfg = def
1090− & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
1091− & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
1092− void $ element "svg" svgRootCfg $ do
1093− dyn_ $ text "one" <$ pure ()
1095− session' "runWithReplace" $ do
795+ describe "runWithReplace" $ session' $ do
1096 it "works" $ runWD $ do
796 it "works" $ runWD $ do
1097 replaceChan :: Chan Text <- liftIO newChan
797 replaceChan :: Chan Text <- liftIO newChan
1098− let setup = findElemWithRetry $ WD.ByTag "div"
798+ let setup = WD.findElem $ WD.ByTag "div"
1099 check ssr = do
799 check ssr = do
1100 -- Check that the original element still exists and has the correct text
800 -- Check that the original element still exists and has the correct text
1101− shouldContainText "two" ssr
801+ WD.getText ssr >>= flip shouldBe "two"
1102− liftIO $ writeChan replaceChan "three"
803+ writeChan replaceChan "three"
1103 elementShouldBeRemoved ssr
805 elementShouldBeRemoved ssr
1104− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
806+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1105 testWidget' setup check $ do
807 testWidget' setup check $ do
1106 replace <- triggerEventWithChan replaceChan
808 replace <- triggerEventWithChan replaceChan
1107 pb <- getPostBuild
809 pb <- getPostBuild
@@ -1111,13 +813,15 @@ tests withDebugging wdConfig caps _selenium = do
1112 it "can be nested in initial widget" $ runWD $ do
814 it "can be nested in initial widget" $ runWD $ do
1113 replaceChan :: Chan Text <- liftIO newChan
815 replaceChan :: Chan Text <- liftIO newChan
1114− let setup = findElemWithRetry $ WD.ByTag "div"
816+ let setup = WD.findElem $ WD.ByTag "div"
1115 check ssr = do
817 check ssr = do
1116 -- Check that the original element still exists and has the correct text
818 -- Check that the original element still exists and has the correct text
1117− shouldContainText "two" ssr
819+ WD.getText ssr >>= flip shouldBe "two"
1118− liftIO $ writeChan replaceChan "three"
821+ writeChan replaceChan "three"
1119 elementShouldBeRemoved ssr
823 elementShouldBeRemoved ssr
1120− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
824+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1121 testWidget' setup check $ void $ flip runWithReplace never $ do
825 testWidget' setup check $ void $ flip runWithReplace never $ do
1122 replace <- triggerEventWithChan replaceChan
826 replace <- triggerEventWithChan replaceChan
1123 pb <- getPostBuild
827 pb <- getPostBuild
@@ -1126,14 +830,16 @@ tests withDebugging wdConfig caps _selenium = do
1126 , el "span" . text <$> replace
830 , el "span" . text <$> replace
1128 it "can be nested in postBuild widget" $ runWD $ do
832 it "can be nested in postBuild widget" $ runWD $ do
1129− replaceChan :: Chan Text <- liftIO newChan
833+ replaceChan <- liftIO newChan
1130− let setup = findElemWithRetry $ WD.ByTag "div"
834+ let setup = WD.findElem $ WD.ByTag "div"
1131 check ssr = do
835 check ssr = do
1132 -- Check that the original element still exists and has the correct text
836 -- Check that the original element still exists and has the correct text
1133− shouldContainText "two" ssr
837+ WD.getText ssr >>= flip shouldBe "two"
1134− liftIO $ writeChan replaceChan "three"
839+ writeChan replaceChan "three"
1135 elementShouldBeRemoved ssr
841 elementShouldBeRemoved ssr
1136− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
842+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1137 testWidget' setup check $ void $ do
843 testWidget' setup check $ void $ do
1138 pb <- getPostBuild
844 pb <- getPostBuild
1139 runWithReplace (pure ()) $ ffor pb $ \() -> do
845 runWithReplace (pure ()) $ ffor pb $ \() -> do
@@ -1159,15 +865,17 @@ tests withDebugging wdConfig caps _selenium = do
1159 replaceChan2 :: Chan Text <- liftIO newChan
865 replaceChan2 :: Chan Text <- liftIO newChan
1160 lock :: MVar () <- liftIO newEmptyMVar
866 lock :: MVar () <- liftIO newEmptyMVar
1161 let check = do
867 let check = do
1162− shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
868+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
1163 liftIO $ do
869 liftIO $ do
1164 writeChan replaceChan1 "one"
870 writeChan replaceChan1 "one"
1165 takeMVar lock
871 takeMVar lock
1166− one <- findElemWithRetry $ WD.ByTag "div"
872+ one <- WD.findElem $ WD.ByTag "div"
1167− shouldContainText "pb" one
873+ WD.getText one >>= flip shouldBe "pb"
1168− liftIO $ writeChan replaceChan2 "two"
875+ writeChan replaceChan2 "two"
1169 elementShouldBeRemoved one
877 elementShouldBeRemoved one
1170− shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
878+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
1171 testWidget (pure ()) check $ void $ do
879 testWidget (pure ()) check $ void $ do
1172 replace1 <- triggerEventWithChan replaceChan1
880 replace1 <- triggerEventWithChan replaceChan1
1173 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
881 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
@@ -1208,12 +916,14 @@ tests withDebugging wdConfig caps _selenium = do
1208 it "works in immediate mode (RHS of prerender)" $ runWD $ do
916 it "works in immediate mode (RHS of prerender)" $ runWD $ do
1209 replaceChan :: Chan Text <- liftIO newChan
917 replaceChan :: Chan Text <- liftIO newChan
1210 let check = do
918 let check = do
1211− checkBodyText "one"
1212− one <- findElemWithRetry $ WD.ByTag "div"
919+ one <- WD.findElem $ WD.ByTag "div"
1213− shouldContainText "one" one
920+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
921+ WD.getText one >>= flip shouldBe "one"
1214− liftIO $ writeChan replaceChan "pb"
923+ writeChan replaceChan "pb"
1215 elementShouldBeRemoved one
925 elementShouldBeRemoved one
1216− shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
926+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
1217 testWidget (pure ()) check $ void $ do
927 testWidget (pure ()) check $ void $ do
1218 replace <- triggerEventWithChan replaceChan
928 replace <- triggerEventWithChan replaceChan
1219 prerender_ blank $ do
929 prerender_ blank $ do
@@ -1221,12 +931,14 @@ tests withDebugging wdConfig caps _selenium = do
1221 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
931 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
1222 replaceChan :: Chan Text <- liftIO newChan
932 replaceChan :: Chan Text <- liftIO newChan
1223 let check = do
933 let check = do
1224− checkBodyText "two"
1225− two <- findElemWithRetry $ WD.ByTag "div"
934+ two <- WD.findElem $ WD.ByTag "div"
1226− shouldContainText "two" two
935+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
936+ WD.getText two >>= flip shouldBe "two"
1227− liftIO $ writeChan replaceChan "three"
938+ writeChan replaceChan "three"
1228 elementShouldBeRemoved two
940 elementShouldBeRemoved two
1229− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
941+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1230 testWidget (pure ()) check $ void $ do
942 testWidget (pure ()) check $ void $ do
1231 replace <- triggerEventWithChan replaceChan
943 replace <- triggerEventWithChan replaceChan
1232 prerender_ blank $ do
944 prerender_ blank $ do
@@ -1236,61 +948,7 @@ tests withDebugging wdConfig caps _selenium = do
1236 , el "span" . text <$> replace
948 , el "span" . text <$> replace
1239− let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
1240− it "removes bracketing comments" $ runWD $ do
1241− replaceChan :: Chan () <- liftIO newChan
1243− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1245− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1246− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1247− checkInnerHtml "div" "before|<p>inner2</p>|after"
1248− testWidget' preSwitchover check $ do
1249− replace <- triggerEventWithChan replaceChan
1252− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1254− it "ignores extra ending bracketing comment" $ runWD $ do
1255− replaceChan :: Chan () <- liftIO newChan
1257− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
1259− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1260− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1261− checkInnerHtml "div" "before|inner2|after"
1262− testWidget' preSwitchover check $ do
1263− replace <- triggerEventWithChan replaceChan
1266− _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
1268− void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
1269− -- TODO This test actually causes a hydration failure, but it wasn't
1270− -- previously detected, so I've marked it pending
1271− xit "ignores missing ending bracketing comments" $ runWD $ do
1272− replaceChan :: Chan () <- liftIO newChan
1275− checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1276− divEl <- findElemWithRetry (WD.ByTag "div")
1277− let wrongHtml = "<!--replace-start-0-->inner1"
1278− actualHtml :: String <- WD.executeJS
1279− [WD.JSArg divEl, WD.JSArg wrongHtml]
1280− "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
1281− actualHtml `shouldBe` wrongHtml
1283− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1284− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1285− checkInnerHtml "div" "before|<p>inner2</p>|after"
1286− testWidget' preSwitchover check $ do
1287− replace <- triggerEventWithChan replaceChan
1290− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1293− session' "traverseDMapWithKeyWithAdjust" $ do
951+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
952 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
953 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296 elClass "span" "key" $ text $ textKey k
954 elClass "span" "key" $ text $ textKey k
@@ -1298,58 +956,58 @@ tests withDebugging wdConfig caps _selenium = do
1298 pure (Identity v)
956 pure (Identity v)
1299 checkItem :: WD.Element -> Text -> Text -> WD ()
957 checkItem :: WD.Element -> Text -> Text -> WD ()
1300 checkItem li k v = do
958 checkItem li k v = do
1301− putStrLnDebug "checkItem"
1302− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
959+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1303− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
960+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1304 checkInitialItems dm xs = do
961 checkInitialItems dm xs = do
1305− putStrLnDebug "checkInitialItems"
1306 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
962 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1307 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
963 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1308− getAndCheckInitialItems dm = withRetry $ do
964+ getAndCheckInitialItems dm = do
1309− putStrLnDebug "getAndCheckInitialItems"
1310 xs <- WD.findElems (WD.ByTag "li")
965 xs <- WD.findElems (WD.ByTag "li")
1311 checkInitialItems dm xs
966 checkInitialItems dm xs
1313 checkRemoval chan k = do
968 checkRemoval chan k = do
1314− putStrLnDebug "checkRemoval"
1315− e <- findElemWithRetry (WD.ById $ textKey k)
969+ e <- WD.findElem (WD.ById $ textKey k)
1316− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
971+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
1317 elementShouldBeRemoved e
973 elementShouldBeRemoved e
1318 checkReplace chan k v = do
974 checkReplace chan k v = do
1319− putStrLnDebug "checkReplace"
1320− e <- findElemWithRetry (WD.ById $ textKey k)
975+ e <- WD.findElem (WD.ById $ textKey k)
1321− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
977+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1322 elementShouldBeRemoved e
979 elementShouldBeRemoved e
1323− e' <- findElemWithRetry $ WD.ById $ textKey k
980+ e' <- WD.findElem (WD.ById $ textKey k)
1324 checkItem e' (textKey k) (T.pack $ show v)
981 checkItem e' (textKey k) (T.pack $ show v)
1325 checkInsert chan k v = do
982 checkInsert chan k v = do
1326− putStrLnDebug "checkInsert"
983+ liftIO $ do
1327− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
984+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1328− e <- findElemWithRetry (WD.ById $ textKey k)
986+ e <- WD.findElem (WD.ById $ textKey k)
1329 checkItem e (textKey k) (T.pack $ show v)
987 checkItem e (textKey k) (T.pack $ show v)
1330 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
988 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1331 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
989 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1332 chan <- liftIO newChan
990 chan <- liftIO newChan
1333− let preSwitchover :: WD [WD.Element]
991+ let static :: WD [WD.Element]
1334− preSwitchover = getAndCheckInitialItems keyMap
992+ static = getAndCheckInitialItems keyMap
1335 check :: [WD.Element] -> WD ()
993 check :: [WD.Element] -> WD ()
1336 check xs = do
994 check xs = do
1337 checkInitialItems keyMap xs
995 checkInitialItems keyMap xs
1338 checkRemoval chan Key_Int
996 checkRemoval chan Key_Int
1339 checkReplace chan Key_Char 'B'
997 checkReplace chan Key_Char 'B'
1340 checkInsert chan Key_Bool True
998 checkInsert chan Key_Bool True
1341− testWidget' preSwitchover check $ do
999+ testWidget' static check $ do
1342 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1000 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1343 liftIO $ dmap `H.shouldBe` keyMap
1001 liftIO $ dmap `H.shouldBe` keyMap
1344 it "handles postBuild correctly" $ runWD $ do
1002 it "handles postBuild correctly" $ runWD $ do
1345 chan <- liftIO newChan
1003 chan <- liftIO newChan
1346− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1004+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1347 check xs = do
1005 check xs = do
1348− withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1006+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
1349 checkRemoval chan Key_Int
1007 checkRemoval chan Key_Int
1350 checkInsert chan Key_Char 'B'
1008 checkInsert chan Key_Char 'B'
1351 checkReplace chan Key_Bool True
1009 checkReplace chan Key_Bool True
1352− testWidget' preSwitchover check $ void $ do
1010+ testWidget' static check $ void $ do
1353 pb <- getPostBuild
1011 pb <- getPostBuild
1354 replace <- triggerEventWithChan chan
1012 replace <- triggerEventWithChan chan
1355 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1013 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1382,7 +1040,7 @@ tests withDebugging wdConfig caps _selenium = do
1382 it "handles postBuild correctly in prerender" $ runWD $ do
1040 it "handles postBuild correctly in prerender" $ runWD $ do
1383 chan <- liftIO newChan
1041 chan <- liftIO newChan
1384 let check = do
1042 let check = do
1385− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1043+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1386 checkRemoval chan Key_Int
1044 checkRemoval chan Key_Int
1387 checkInsert chan Key_Char 'B'
1045 checkInsert chan Key_Char 'B'
1388 checkReplace chan Key_Bool True
1046 checkReplace chan Key_Bool True
@@ -1393,7 +1051,7 @@ tests withDebugging wdConfig caps _selenium = do
1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1051 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1394 liftIO $ dmap `H.shouldBe` keyMap
1052 liftIO $ dmap `H.shouldBe` keyMap
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1054+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1397 let textKeyInt k = "key" <> T.pack (show k)
1055 let textKeyInt k = "key" <> T.pack (show k)
1398 intMap = IntMap.fromList
1056 intMap = IntMap.fromList
1399 [ (1, "one")
1057 [ (1, "one")
@@ -1407,89 +1065,89 @@ tests withDebugging wdConfig caps _selenium = do
1408 checkItem :: WD.Element -> Text -> Text -> WD ()
1066 checkItem :: WD.Element -> Text -> Text -> WD ()
1409 checkItem li k v = do
1067 checkItem li k v = do
1410− putStrLnDebug "checkItem"
1411− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1068+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1412− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1069+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1413 checkInitialItems dm xs = do
1070 checkInitialItems dm xs = do
1414− putStrLnDebug "checkInitialItems"
1415 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
1071 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
1416 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1072 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1417− getAndCheckInitialItems dm = withRetry $ do
1073+ getAndCheckInitialItems dm = do
1418− putStrLnDebug "getAndCheckInitialItems"
1419 xs <- WD.findElems (WD.ByTag "li")
1074 xs <- WD.findElems (WD.ByTag "li")
1420 checkInitialItems dm xs
1075 checkInitialItems dm xs
1422 checkRemoval chan k = do
1077 checkRemoval chan k = do
1423− putStrLnDebug "checkRemoval"
1424− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1078+ e <- WD.findElem (WD.ById $ textKeyInt k)
1425− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1080+ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1426 elementShouldBeRemoved e
1082 elementShouldBeRemoved e
1427 checkReplace chan k v = do
1083 checkReplace chan k v = do
1428− putStrLnDebug "checkReplace"
1429− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1084+ e <- WD.findElem (WD.ById $ textKeyInt k)
1430− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1086+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1431 elementShouldBeRemoved e
1088 elementShouldBeRemoved e
1432− e' <- findElemWithRetry (WD.ById $ textKeyInt k)
1089+ e' <- WD.findElem (WD.ById $ textKeyInt k)
1433− withRetry $ checkItem e' (textKeyInt k) v
1090+ checkItem e' (textKeyInt k) v
1434 checkInsert chan k v = do
1091 checkInsert chan k v = do
1435− putStrLnDebug "checkInsert"
1092+ liftIO $ do
1436− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1093+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1437− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1095+ e <- WD.findElem (WD.ById $ textKeyInt k)
1438 checkItem e (textKeyInt k) v
1096 checkItem e (textKeyInt k) v
1439 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1097 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1440− xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1098+ it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1441 chan <- liftIO newChan
1099 chan <- liftIO newChan
1442− let preSwitchover = getAndCheckInitialItems intMap
1100+ let static = getAndCheckInitialItems intMap
1443 check xs = do
1101 check xs = do
1444 checkInitialItems intMap xs
1102 checkInitialItems intMap xs
1445 checkRemoval chan 1
1103 checkRemoval chan 1
1446 checkReplace chan 2 "deux"
1104 checkReplace chan 2 "deux"
1447 checkInsert chan 4 "four"
1105 checkInsert chan 4 "four"
1448− testWidget' preSwitchover check $ void $ do
1106+ testWidget' static check $ void $ do
1449 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1107 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1450 liftIO $ im `H.shouldBe` intMap
1108 liftIO $ im `H.shouldBe` intMap
1451− xit "handles postBuild correctly" $ runWD $ do
1109+ it "handles postBuild correctly" $ runWD $ do
1452 chan <- liftIO newChan
1110 chan <- liftIO newChan
1453− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1111+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
1454 check xs = do
1112 check xs = do
1455− withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1113+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch intMap) xs
1456 checkRemoval chan 1
1114 checkRemoval chan 1
1457 checkInsert chan 2 "deux"
1115 checkInsert chan 2 "deux"
1458 checkReplace chan 3 "trois"
1116 checkReplace chan 3 "trois"
1459− testWidget' preSwitchover check $ void $ do
1117+ testWidget' static check $ void $ do
1460 pb <- getPostBuild
1118 pb <- getPostBuild
1461 replace <- triggerEventWithChan chan
1119 replace <- triggerEventWithChan chan
1462 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1120 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1463 liftIO $ dmap `H.shouldBe` intMap
1121 liftIO $ dmap `H.shouldBe` intMap
1464− xit "can delete/update/insert when built in prerender" $ runWD $ do
1122+ it "can delete/update/insert when built in prerender" $ runWD $ do
1465 chan <- liftIO newChan
1123 chan <- liftIO newChan
1466 let check = do
1124 let check = do
1467 _ <- getAndCheckInitialItems intMap
1125 _ <- getAndCheckInitialItems intMap
1468 checkRemoval chan 1
1126 checkRemoval chan 1
1469 checkReplace chan 2 "deux"
1127 checkReplace chan 2 "deux"
1470− checkInsert chan 4 "quatre"
1128+ checkInsert chan 3 "trois"
1471 testWidget (pure ()) check $ do
1129 testWidget (pure ()) check $ do
1472 replace <- triggerEventWithChan chan
1130 replace <- triggerEventWithChan chan
1473 prerender_ (pure ()) $ do
1131 prerender_ (pure ()) $ do
1474 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
1132 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
1475 liftIO $ dmap `H.shouldBe` intMap
1133 liftIO $ dmap `H.shouldBe` intMap
1476− xit "can delete/update/insert when built in immediate mode" $ runWD $ do
1134+ it "can delete/update/insert when built in immediate mode" $ runWD $ do
1477 chan <- liftIO newChan
1135 chan <- liftIO newChan
1478 let check = do
1136 let check = do
1479 _ <- getAndCheckInitialItems intMap
1137 _ <- getAndCheckInitialItems intMap
1480 checkRemoval chan 1
1138 checkRemoval chan 1
1481 checkReplace chan 2 "deux"
1139 checkReplace chan 2 "deux"
1482− checkInsert chan 4 "quatre"
1140+ checkInsert chan 3 "trois"
1483 testWidget (pure ()) check $ void $ do
1141 testWidget (pure ()) check $ void $ do
1484 pb <- getPostBuild
1142 pb <- getPostBuild
1485 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1143 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1486 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1144 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1487 liftIO $ dmap `H.shouldBe` intMap
1145 liftIO $ dmap `H.shouldBe` intMap
1488 -- Should be fixed by prerender changes!
1146 -- Should be fixed by prerender changes!
1489− xit "handles postBuild correctly in prerender" $ runWD $ do
1147+ it "handles postBuild correctly in prerender" $ runWD $ do
1490 chan <- liftIO newChan
1148 chan <- liftIO newChan
1491 let check = do
1149 let check = do
1492− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1150+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
1493 checkRemoval chan 1
1151 checkRemoval chan 1
1494 checkInsert chan 2 "deux"
1152 checkInsert chan 2 "deux"
1495 checkReplace chan 3 "trois"
1153 checkReplace chan 3 "trois"
@@ -1500,30 +1158,47 @@ tests withDebugging wdConfig caps _selenium = do
1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1158 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1501 liftIO $ dmap `H.shouldBe` intMap
1159 liftIO $ dmap `H.shouldBe` intMap
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1161+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1162 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1505− widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1163+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1506− elClass "span" "key" $ text $ textKey2 k
1164+ elClass "span" "key" $ text $ textKey k
1507 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
1165 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
1508 pure (Identity v)
1166 pure (Identity v)
1509− textKey2 :: Key2 a -> Text
1167+ textKey :: Key2 a -> Text
1510− textKey2 = \case
1168+ textKey = \case
1511 Key2_Int i -> "i" <> T.pack (show i)
1169 Key2_Int i -> "i" <> T.pack (show i)
1512 Key2_Char c -> "c" <> T.pack [c]
1170 Key2_Char c -> "c" <> T.pack [c]
1513 checkItem :: WD.Element -> Text -> Text -> WD ()
1171 checkItem :: WD.Element -> Text -> Text -> WD ()
1514 checkItem li k v = do
1172 checkItem li k v = do
1515− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1173+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1516− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1174+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1517 checkInitialItems dm xs = do
1175 checkInitialItems dm xs = do
1518 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1176 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1519− forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
1177+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1520− getAndCheckInitialItems dm = withRetry $ do
1178+ getAndCheckInitialItems dm = do
1521 xs <- WD.findElems (WD.ByTag "li")
1179 xs <- WD.findElems (WD.ByTag "li")
1522 checkInitialItems dm xs
1180 checkInitialItems dm xs
1524− moveSpec
1182+ checkRemoval chan k = do
1525− :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
1183+ e <- WD.findElem (WD.ById $ textKey k)
1526− -> H.SpecM (WdTestSession ()) ()
1184+ liftIO $ do
1185+ writeChan chan $ deleteDMapKey k
1187+ elementShouldBeRemoved e
1188+ checkReplace chan k v = do
1189+ e <- WD.findElem (WD.ById $ textKey k)
1191+ writeChan chan $ insertDMapKey k (Identity v)
1193+ elementShouldBeRemoved e
1194+ e' <- WD.findElem (WD.ById $ textKey k)
1195+ checkItem e' (textKey k) (T.pack $ show v)
1196+ checkInsert chan k v = do
1198+ writeChan chan $ insertDMapKey k (Identity v)
1200+ e <- WD.findElem (WD.ById $ textKey k)
1201+ checkItem e (textKey k) (T.pack $ show v)
1527 moveSpec testMove = do
1202 moveSpec testMove = do
1528 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1203 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1529 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
1204 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1537,40 +1212,39 @@ tests withDebugging wdConfig caps _selenium = do
1537 shouldContainText (T.strip $ T.unlines ["i11","i22","i33","i44"]) body
1212 shouldContainText (T.strip $ T.unlines ["i11","i22","i33","i44"]) body
1538 liftIO $ writeChan chan (swapDMapKey (Key2_Int 2) (Key2_Int 3))
1213 liftIO $ writeChan chan (swapDMapKey (Key2_Int 2) (Key2_Int 3))
1539 shouldContainText (T.strip $ T.unlines ["i11","i33","i22","i44"]) body
1214 shouldContainText (T.strip $ T.unlines ["i11","i33","i22","i44"]) body
1540−-- TODO re-enable this
1541−-- it "can move items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
1215+ it "can move items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
1542−-- shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body
1216+ shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body
1543−-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))
1217+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))
1544−-- shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1218+ shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1545−-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete
1219+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete
1546−-- shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1220+ shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1547−-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too
1221+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too
1548−-- shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1222+ shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1549−-- liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2) -- this step will fail if the above caused an exception, thus works as a proxy for detecting the exception given we can't catch it
1223+ liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2) -- this step will fail if the above caused an exception, thus works as a proxy for detecting the exception given we can't catch it
1550−-- shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1224+ shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1552 describe "hydration" $ moveSpec $ \initMap test -> do
1226 describe "hydration" $ moveSpec $ \initMap test -> do
1553 chan <- liftIO newChan
1227 chan <- liftIO newChan
1554− let preSwitchover = getAndCheckInitialItems initMap
1228+ let static = getAndCheckInitialItems initMap
1555 check xs = do
1229 check xs = do
1556 checkInitialItems initMap xs
1230 checkInitialItems initMap xs
1557− body <- getBody
1231+ body <- WD.findElem (WD.ByTag "body")
1558 test body chan
1232 test body chan
1559− testWidget' preSwitchover check $ void $ do
1233+ testWidget' static check $ void $ do
1560 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1234 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1561 liftIO $ assertEqual "DMap" initMap dmap
1235 liftIO $ assertEqual "DMap" initMap dmap
1563 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1237 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1564 chan <- liftIO newChan
1238 chan <- liftIO newChan
1565 replace <- liftIO newChan
1239 replace <- liftIO newChan
1566− lock :: MVar () <- liftIO newEmptyMVar
1240+ lock <- liftIO newEmptyMVar
1567 let check = do
1241 let check = do
1568 liftIO $ do
1242 liftIO $ do
1569 writeChan replace ()
1243 writeChan replace ()
1570 takeMVar lock
1244 takeMVar lock
1571 xs <- getAndCheckInitialItems initMap
1245 xs <- getAndCheckInitialItems initMap
1572 checkInitialItems initMap xs
1246 checkInitialItems initMap xs
1573− body <- getBody
1247+ body <- WD.findElem (WD.ByTag "body")
1574 test body chan
1248 test body chan
1575 testWidget (pure ()) check $ void $ do
1249 testWidget (pure ()) check $ void $ do
1576 e <- triggerEventWithChan replace
1250 e <- triggerEventWithChan replace
@@ -1580,56 +1254,6 @@ tests withDebugging wdConfig caps _selenium = do
1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1254 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1581 liftIO $ assertEqual "DMap" initMap dmap
1255 liftIO $ assertEqual "DMap" initMap dmap
1583− session' "hydrating invalid HTML" $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1585− let preSwitchover = do
1586− checkBodyText "before\ninner\nafter"
1587− -- Two <p> tags should be present
1588− (p1, p2) <- WD.findElems (WD.ByTag "p") >>= \case
1589− [p1, p2] -> pure (p1, p2)
1590− _ -> error "Unexpected number of `p` tags (expected 2)"
1591− ol <- findElemWithRetry (WD.ByTag "ol")
1592− shouldContainText "before" p1
1593− shouldContainText "inner" ol
1594− shouldContainText "" p2
1596− check (p1, ol, p2) = do
1597− checkBodyText "before\ninner\nafter"
1598− shouldContainText "before\ninner\nafter" p1
1599− elementShouldBeRemoved ol
1600− elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1603− -- This is deliberately invalid HTML, the browser will interpret it as
1604− -- <p>before</p><ol>inner</ol>after<p></p>
1607− el "ol" $ text "inner"
1610− -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
1611− -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
1612− -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1613− session' "dropdown" $ do
1614− let doTest expectedOpts (initialValue :: Text) = do
1616− es <- findElemsWithRetry $ WD.ByTag "option"
1617− opts <- mapM fetchElement es
1618− assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
1619− testWidget doCheck doCheck $ do
1620− void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
1621− fetchElement e = do
1622− val <- WD.attr e "value"
1623− sel <- WD.attr e "selected"
1624− return (fromMaybe "" val, isJust sel)
1625− -- 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)
1626− -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
1627− xit "statically renders initial values (on aa)" $ runWD $ do
1628− doTest [("0",True),("1",False)] "aa"
1629− -- 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
1630− xit "statically renders initial values (on bb)" $ runWD $ do
1631− doTest [("0",False),("1",True)] "bb"
1633data Selenium = Selenium
1257data Selenium = Selenium
1634 { _selenium_portNumber :: PortNumber
1258 { _selenium_portNumber :: PortNumber
1635 , _selenium_stopServer :: IO ()
1259 , _selenium_stopServer :: IO ()
@@ -1646,177 +1270,136 @@ startSeleniumServer port = do
1647withSeleniumServer :: (Selenium -> IO ()) -> IO ()
1271withSeleniumServer :: (Selenium -> IO ()) -> IO ()
1648withSeleniumServer f = do
1272withSeleniumServer f = do
1273+ port <- getFreePort
1649− stopServer <- startSeleniumServer seleniumPort
1274+ stopServer <- startSeleniumServer port
1650 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
1275 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
1651 f $ Selenium
1276 f $ Selenium
1652− { _selenium_portNumber = seleniumPort
1277+ { _selenium_portNumber = port
1653 , _selenium_stopServer = stopServer
1278 , _selenium_stopServer = stopServer
1656−triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender js t m) => Chan a -> m (Event t a)
1281+triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender t m) => Chan a -> m (Event t a)
1657triggerEventWithChan chan = do
1282triggerEventWithChan chan = do
1658 (e, trigger) <- newTriggerEvent
1283 (e, trigger) <- newTriggerEvent
1659 -- In prerender because we only want to do this on the client
1284 -- In prerender because we only want to do this on the client
1660 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
1285 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
1663−shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
1664−shouldBeWithRetryM m expected = withRetry $ do
1666− got `shouldBe` expected
1668assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
1288assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
1669assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
1289assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
1671elementShouldBeRemoved :: WD.Element -> WD ()
1291elementShouldBeRemoved :: WD.Element -> WD ()
1672−elementShouldBeRemoved e = withRetry $ do
1292+elementShouldBeRemoved e = do
1673 try (WD.getText e) >>= \case
1293 try (WD.getText e) >>= \case
1674 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
1294 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
1675 Left err -> throwM err
1295 Left err -> throwM err
1676 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
1296 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
1678shouldContainText :: Text -> WD.Element -> WD ()
1298shouldContainText :: Text -> WD.Element -> WD ()
1679−shouldContainText t = withRetry . shouldContainTextNoRetry t
1681−shouldContainTextNoRetry :: Text -> WD.Element -> WD ()
1682−shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText
1299+shouldContainText t = flip shouldBe t <=< WD.getText
1684checkBodyText :: Text -> WD ()
1301checkBodyText :: Text -> WD ()
1685checkBodyText = checkTextInTag "body"
1302checkBodyText = checkTextInTag "body"
1687checkTextInTag :: Text -> Text -> WD ()
1304checkTextInTag :: Text -> Text -> WD ()
1688−checkTextInTag t expected = do
1689− e <- findElemWithRetry (WD.ByTag t)
1690− shouldContainText expected e
1305+checkTextInTag t expected = WD.findElem (WD.ByTag t) >>= shouldContainText expected
1692checkTextInId :: Text -> Text -> WD ()
1307checkTextInId :: Text -> Text -> WD ()
1693−checkTextInId i expected = do
1308+checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
1694− e <- findElemWithRetry (WD.ById i)
1695− shouldContainText expected e
1697−findElemWithRetry :: Selector -> WD WD.Element
1698−findElemWithRetry = withRetry . WD.findElem
1700−findElemsWithRetry :: Selector -> WD [WD.Element]
1701−findElemsWithRetry = withRetry . WD.findElems
1703−getBody :: WD WD.Element
1704−getBody = WD.findElem $ WD.ByTag "body"
1706−withRetry :: forall a. WD a -> WD a
1707−withRetry a = wait 300
1708− where wait :: Int -> WD a
1710− wait n = try a >>= \case
1711− Left (e :: SomeException) -> do
1712− liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1714− Right v -> return v
1716divId :: DomBuilder t m => Text -> m a -> m a
1310divId :: DomBuilder t m => Text -> m a -> m a
1717divId i = elAttr "div" ("id" =: i)
1311divId i = elAttr "div" ("id" =: i)
1719−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)
1313+type TestWidget n 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)
1721−testWidgetStaticDebug
1315+testWidgetStatic
1723− -> WD b
1316+ :: WD b
1724 -- ^ Webdriver commands to run before JS runs and after hydration switchover
1317 -- ^ Webdriver commands to run before JS runs and after hydration switchover
1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1318 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1726 -- ^ Widget we are testing
1319 -- ^ Widget we are testing
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1321+testWidgetStatic w = testWidget (void w) w
1730-- | TODO: do something about JSExceptions not causing tests to fail
1323-- | TODO: do something about JSExceptions not causing tests to fail
1731−testWidgetDebug
1324+testWidget
1734− -> WD ()
1325+ :: WD ()
1735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1326 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1737 -- ^ Webdriver commands to run after hydration switchover
1328 -- ^ Webdriver commands to run after hydration switchover
1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1329 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1739 -- ^ Widget we are testing
1330 -- ^ Widget we are testing
1741−testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1742− testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1332+testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
1744−data HydrationFailedException = HydrationFailedException deriving Show
1745−instance Exception HydrationFailedException
1747-- | TODO: do something about JSExceptions not causing tests to fail
1334-- | TODO: do something about JSExceptions not causing tests to fail
1748−testWidgetDebug'
1335+testWidget'
1751− -> WD a
1336+ :: WD a
1752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1337 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1753 -> (a -> WD b)
1338 -> (a -> WD b)
1754 -- ^ Webdriver commands to run after hydration switchover
1339 -- ^ Webdriver commands to run after hydration switchover
1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1340 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1756 -- ^ Widget we are testing (contents of body)
1341 -- ^ Widget we are testing (contents of body)
1758−testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1343+testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do
1759− let putStrLnDebug :: MonadIO m => Text -> m ()
1760− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1761− staticApp = do
1344+ let staticApp = do
1762 el "head" $ pure ()
1345 el "head" $ pure ()
1763 el "body" $ do
1346 el "body" $ do
1764 bodyWidget
1347 bodyWidget
1765 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1348 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1766− putStrLnDebug "rendering static"
1767− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1349+ ((), html) <- liftIO $ renderStatic staticApp
1768− putStrLnDebug "rendered static"
1769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1350 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1351 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1772 let entryPoint = do
1352 let entryPoint = do
1773− putStrLnDebug "taking waitBeforeJS"
1774 liftIO $ takeMVar waitBeforeJS
1353 liftIO $ takeMVar waitBeforeJS
1775− let switchOverAction = do
1776− putStrLnDebug "switchover syncPoint"
1778− putStrLnDebug "putting waitUntilSwitchover"
1779− liftIO $ putMVar waitUntilSwitchover ()
1354+ mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
1780− putStrLnDebug "put waitUntilSwitchover"
1781− putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1782− mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1783− putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1784 syncPoint
1355 syncPoint
1785− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1356+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
1786− putStrLnDebug "sending response"
1787− r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1357+ sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1788− putStrLnDebug "sent response"
1358+ port <- getFreePort
1790 waitJSaddle <- liftIO newEmptyMVar
1359 waitJSaddle <- liftIO newEmptyMVar
1791 let settings = foldr ($) Warp.defaultSettings
1360 let settings = foldr ($) Warp.defaultSettings
1792− [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
1361+ [ Warp.setPort $ fromIntegral (toInteger port)
1793− , Warp.setBeforeMainLoop $ do
1362+ , Warp.setBeforeMainLoop $ putMVar waitJSaddle ()
1794− putStrLnDebug "putting waitJSaddle"
1795− putMVar waitJSaddle ()
1796− putStrLnDebug "put waitJSaddle"
1798 -- hSilence to get rid of ConnectionClosed logs
1364 -- hSilence to get rid of ConnectionClosed logs
1799− silenceIfDebug = if withDebugging then id else hSilence [stderr]
1800− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1365+ jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
1801− withAsync' jsaddleWarp $ do
1366+ jsaddleTid <- liftIO jsaddleWarp
1802− putStrLnDebug "taking waitJSaddle"
1803− liftIO $ takeMVar waitJSaddle
1367+ liftIO $ takeMVar waitJSaddle
1804− putStrLnDebug "opening page"
1805− WD.openPage $ "http://localhost:" <> show jsaddlePort
1368+ WD.openPage $ "http://localhost:" <> show port
1806− putStrLnDebug "running beforeJS"
1807− a <- beforeJS
1369+ a <- beforeJS
1808− putStrLnDebug "putting waitBeforeJS"
1809− liftIO $ putMVar waitBeforeJS ()
1370+ liftIO $ putMVar waitBeforeJS ()
1810− putStrLnDebug "taking waitUntilSwitchover"
1371+ liftIO $ takeMVar waitUntilSwitchover
1811− liftIO $ takeMVar waitUntilSwitchover
1372+ liftIO $ threadDelay 100000 -- wait a bit
1812− putStrLnDebug "running afterSwitchover"
1373+ b <- afterSwitchover a
1813− afterSwitchover a
1374+ liftIO $ killThread jsaddleTid
1815−withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1378+-- TODO: Should this be part of more widely used module?
1816−withAsync' f g = bracket
1379+-- TODO: Ensure port is not taken
1817− (liftIO $ Async.async f)
1380+getFreePort :: MonadIO m => m PortNumber
1818− (liftIO . Async.uninterruptibleCancel)
1381+getFreePort = liftIO $ withSocketsDo $ do
1819− (const g)
1382+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
1383+ bracket (open addr) close socketPort
1386+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1387+ bind sock (addrAddress addr)
1390+testWidgetDebug :: MonadIO n => (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> n ()
1391+testWidgetDebug bodyWidget = liftIO $ do
1393+ el "head" $ pure ()
1396+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1397+ ((), html) <- renderStatic staticApp
1398+ let entryPoint = do
1399+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
1401+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1402+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
1821data Key2 a where
1404data Key2 a where
1822 Key2_Int :: Int -> Key2 Int
1405 Key2_Int :: Int -> Key2 Int
@@ -1825,4 +1408,18 @@ data Key2 a where
1825deriveGEq ''Key2
1408deriveGEq ''Key2
1826deriveGCompare ''Key2
1409deriveGCompare ''Key2
1827deriveGShow ''Key2
1410deriveGShow ''Key2
1828−deriveArgDict ''Key2
1411+
1412+instance ShowTag Key2 Identity where
1413+ showTaggedPrec = \case
1414+ Key2_Int _ -> showsPrec
1415+ Key2_Char _ -> showsPrec
1417+instance EqTag Key2 Identity where
1418+ eqTagged (Key2_Int _) (Key2_Int _) = (==)
1419+ eqTagged (Key2_Char _) (Key2_Char _) = (==)
1421+instance ArgDict Key2 where
1422+ type ConstraintsFor Key2 c = (c Int, c Char)
1425+ Key2_Char _ -> Dict