9c49db4 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Test and fixes for hydration immediate mode inputElement

9c49db4Tom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+10−5

compare with develop

unifiedsplit

@@ -109,6 +109,7 @@ import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events

109import GHCJS.DOM.EventM (EventM, event, on)

110import qualified GHCJS.DOM.EventM as DOM

111import qualified GHCJS.DOM.FileList as FileList

112+import qualified GHCJS.DOM.DocumentOrShadowRoot as Document

112import qualified GHCJS.DOM.HTMLInputElement as Input

113import qualified GHCJS.DOM.HTMLInputElement as Input

113import qualified GHCJS.DOM.HTMLSelectElement as Select

114import qualified GHCJS.DOM.HTMLSelectElement as Select

114import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

115import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

@@ -210,9 +211,11 @@ addHydrationStepWithSetup setup f = getHydrationMode >>= \case

210 HydrationDomBuilderT $ modify' (>> f s)

211 HydrationDomBuilderT $ modify' (>> f s)

211

212

212-- | Add a hydration step

213-- | Add a hydration step

213−addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()

214+addHydrationStep :: (MonadIO m, Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m)) => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()

214addHydrationStep m = getHydrationMode >>= \case

215addHydrationStep m = getHydrationMode >>= \case

215− HydrationMode_Immediate -> pure ()

216+ HydrationMode_Immediate -> do

217+ events <- askEvents

218+ lift $ runHydrationRunnerT m Nothing undefined events

216 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify' (>> m)

219 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify' (>> m)

217

220

218-- | A monad for DomBuilder which just gets the results of children and pushes

221-- | A monad for DomBuilder which just gets the results of children and pushes

@@ -552,7 +555,7 @@ hydrateTextNode t = do

552

555

553

556

554{-# INLINABLE commentNodeInternal #-}

557{-# INLINABLE commentNodeInternal #-}

555−commentNodeInternal :: (MonadJSM m, MonadFix m, ToDOMString contents, Reflex t, Adjustable t m) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Comment

558+commentNodeInternal :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, ToDOMString contents, Reflex t, Adjustable t m) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Comment

556commentNodeInternal !t mSetContents = getHydrationMode >>= \case

559commentNodeInternal !t mSetContents = getHydrationMode >>= \case

557 HydrationMode_Immediate -> do

560 HydrationMode_Immediate -> do

558 n <- makeNodeInternal (askDocument >>= \doc -> createComment doc t)

561 n <- makeNodeInternal (askDocument >>= \doc -> createComment doc t)

@@ -659,6 +662,8 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT

659

662

660 (fileChange, triggerFileChange) <- newTriggerEvent

663 (fileChange, triggerFileChange) <- newTriggerEvent

661

664

665+ doc <- askDocument

666+

662 -- Expected initial value from config

667 -- Expected initial value from config

663 let v0 = _inputElementConfig_initialValue cfg

668 let v0 = _inputElementConfig_initialValue cfg

664

669

@@ -682,11 +687,11 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT

682 v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

687 v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

683 liftIO $ triggerChangeBySetValue v

688 liftIO $ triggerChangeBySetValue v

684

689

685− -- TODO look at initial focus at hydration time?

686 let focusChange' = leftmost

690 let focusChange' = leftmost

687 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

691 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

688 , True <$ Reflex.select (_element_events e) (WrapArg Focus)

692 , True <$ Reflex.select (_element_events e) (WrapArg Focus)

689 ]

693 ]

694+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

690 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

695 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

691

696

692 Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

697 Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

@@ -712,7 +717,7 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT

712 ]

717 ]

713 checked <- holdUniqDyn checked'

718 checked <- holdUniqDyn checked'

714

719

715− let initialFocus = False --TODO: Is this correct?

720+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

716 hasFocus <- holdDyn initialFocus focusChange

721 hasFocus <- holdDyn initialFocus focusChange

717

722

718 v <- holdDyn v0 $ leftmost

723 v <- holdDyn v0 $ leftmost

reflex-dom-core/test/hydration.hs+209−104

@@ -220,113 +220,217 @@ main = hspec $ parallel $ do

220 pure ()

221

222 describe "inputElement" $ parallel $ do

223+ describe "hydration" $ do

223− it "doesn't wipe user input when switching over" $ do

224+ it "doesn't wipe user input when switching over" $ do

224− inputRef <- newIORef ""

225+ inputRef <- newIORef ""

225− testWidget'

226+ testWidget'

226− (do

227+ (do

227− e <- WD.findElem $ WD.ByTag "input"

228+ e <- WD.findElem $ WD.ByTag "input"

228− WD.sendKeys "hello world" e

229+ WD.sendKeys "hello world" e

229− pure e)

230+ pure e)

230− (\e -> do

231+ (\e -> do

231− t <- WD.attr e "value"

232+ t <- WD.attr e "value"

232− liftIO $ t `shouldBe` Just "hello world"

233+ liftIO $ t `shouldBe` Just "hello world"

233− WD.click <=< WD.findElem $ WD.ByTag "button"

234− input <- liftIO $ readIORef inputRef

235− liftIO $ input `shouldBe` "hello world"

236− ) $ do

237− e <- inputElement def

238− click <- button "save"

239− performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

240− it "captures user input after switchover" $ do

241− inputRef <- newIORef ""

242− let checkValue = do

243− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"

244 WD.click <=< WD.findElem $ WD.ByTag "button"

234 WD.click <=< WD.findElem $ WD.ByTag "button"

245 input <- liftIO $ readIORef inputRef

235 input <- liftIO $ readIORef inputRef

246 liftIO $ input `shouldBe` "hello world"

236 liftIO $ input `shouldBe` "hello world"

237+ ) $ do

238+ e <- inputElement def

239+ click <- button "save"

240+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

241+ it "captures user input after switchover" $ do

242+ inputRef <- newIORef ""

243+ let checkValue = do

244+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"

245+ WD.click <=< WD.findElem $ WD.ByTag "button"

246+ input <- liftIO $ readIORef inputRef

247+ liftIO $ input `shouldBe` "hello world"

248+ testWidget (pure ()) checkValue $ do

249+ e <- inputElement def

250+ click <- button "save"

251+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

252+ it "sets focus appropriately" $ do

253+ focusRef <- newIORef False

254+ let checkValue = do

255+ liftIO $ readIORef focusRef >>= flip shouldBe False

256+ e <- WD.findElem $ WD.ByTag "input"

257+ WD.click e

258+ liftIO $ threadDelay 100000

259+ liftIO $ readIORef focusRef >>= flip shouldBe True

260+ testWidget (pure ()) checkValue $ do

261+ e <- inputElement def

262+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_inputElement_hasFocus e)

263+ it "sets focus when focus occurs before hydration" $ do

264+ focusRef <- newIORef False

265+ let setup = do

266+ e <- WD.findElem $ WD.ByTag "input"

267+ WD.click e

268+ hasFocus <- (== e) <$> WD.activeElem

269+ liftIO $ do

270+ hasFocus `shouldBe` True

271+ readIORef focusRef >>= flip shouldBe False

272+ check = liftIO $ readIORef focusRef >>= flip shouldBe True

273+ testWidget setup check $ do

274+ e <- inputElement def

275+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_inputElement_hasFocus e)

276+ it "sets value appropriately" $ do

277+ valueByUIRef <- newIORef ""

278+ valueRef <- newIORef ""

279+ setValueChan :: Chan Text <- newChan

280+ let checkValue = do

281+ liftIO $ readIORef valueByUIRef >>= flip shouldBe ""

282+ liftIO $ readIORef valueRef >>= flip shouldBe ""

283+ e <- WD.findElem $ WD.ByTag "input"

284+ WD.sendKeys "hello" e

285+ liftIO $ do

286+ threadDelay 100000

287+ readIORef valueByUIRef >>= flip shouldBe "hello"

288+ readIORef valueRef >>= flip shouldBe "hello"

289+ writeChan setValueChan "world"

290+ threadDelay 100000

291+ readIORef valueByUIRef >>= flip shouldBe "hello"

292+ readIORef valueRef >>= flip shouldBe "world"

293+ testWidget (pure ()) checkValue $ do

294+ (setValue, triggerSetValue) <- newTriggerEvent

295+ prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do

296+ triggerSetValue =<< readChan setValueChan

297+ e <- inputElement $ def & inputElementConfig_setValue .~ setValue

298+ performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e

299+ performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)

300+ it "sets checked appropriately" $ do

301+ checkedByUIRef <- newIORef False

302+ checkedRef <- newIORef False

303+ setCheckedChan <- newChan

304+ let checkValue = do

305+ liftIO $ readIORef checkedByUIRef >>= flip shouldBe False

306+ liftIO $ readIORef checkedRef >>= flip shouldBe False

307+ e <- WD.findElem $ WD.ByTag "input"

308+ WD.moveToCenter e

309+ WD.click e

310+ liftIO $ do

311+ threadDelay 100000

312+ readIORef checkedByUIRef >>= flip shouldBe True

313+ readIORef checkedRef >>= flip shouldBe True

314+ writeChan setCheckedChan False

315+ threadDelay 100000

316+ readIORef checkedByUIRef >>= flip shouldBe True

317+ readIORef checkedRef >>= flip shouldBe False

318+ testWidget (pure ()) checkValue $ do

319+ (setChecked, triggerSetChecked) <- newTriggerEvent

320+ prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do

321+ triggerSetChecked =<< readChan setCheckedChan

322+ e <- inputElement $ def

323+ & initialAttributes .~ "type" =: "checkbox"

324+ & inputElementConfig_setChecked .~ setChecked

325+ performEvent_ $ liftIO . writeIORef checkedByUIRef <$> _inputElement_checkedChange e

326+ performEvent_ $ liftIO . writeIORef checkedRef <$> updated (_inputElement_checked e)

327+ it "captures file uploads" $ do

328+ filesRef :: IORef [Text] <- newIORef []

329+ let uploadFile = do

330+ e <- WD.findElem $ WD.ByTag "input"

331+ path <- liftIO $ writeSystemTempFile "testFile" "file contents"

332+ WD.sendKeys (T.pack path) e

333+ WD.click <=< WD.findElem $ WD.ByTag "button"

334+ liftIO $ removeFile path

335+ input <- liftIO $ readIORef filesRef

336+ liftIO $ input `shouldBe` [T.pack $ FilePath.takeFileName path]

337+ testWidget (pure ()) uploadFile $ do

338+ e <- inputElement $ def & initialAttributes .~ "type" =: "file"

339+ click <- button "save"

340+ prerender (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do

341+ names <- liftJSM $ traverse File.getName fs

342+ liftIO $ writeIORef filesRef names

343+

344+ describe "hydration/immediate" $ do

345+ it "captures user input after switchover" $ do

346+ inputRef :: IORef Text <- newIORef ""

347+ let checkValue = do

348+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"

349+ WD.click <=< WD.findElem $ WD.ByTag "button"

350+ input <- liftIO $ readIORef inputRef

351+ liftIO $ input `shouldBe` "hello world"

247− testWidget (pure ()) checkValue $ do

352+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do

248− e <- inputElement def

353+ e <- inputElement def

249− click <- button "save"

354+ click <- button "save"

250− performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

355+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

251− it "sets focus appropriately" $ do

356+ it "sets focus appropriately" $ do

252− focusRef <- newIORef False

357+ focusRef <- newIORef False

253− let checkValue = do

358+ let checkValue = do

254− liftIO $ readIORef focusRef >>= flip shouldBe False

359+ liftIO $ readIORef focusRef >>= flip shouldBe False

255− e <- WD.findElem $ WD.ByTag "input"

360+ e <- WD.findElem $ WD.ByTag "input"

256− WD.moveToCenter e

257− WD.click e

361+ WD.click e

258− liftIO $ threadDelay 100000

362+ liftIO $ threadDelay 100000

259− liftIO $ readIORef focusRef >>= flip shouldBe True

363+ liftIO $ readIORef focusRef >>= flip shouldBe True

260− testWidget (pure ()) checkValue $ do

364+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do

261− e <- inputElement def

365+ e <- inputElement def

262− performEvent_ $ liftIO . writeIORef focusRef <$> updated (_inputElement_hasFocus e)

366+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_inputElement_hasFocus e)

263− it "sets value appropriately" $ do

367+ it "sets value appropriately" $ do

264− valueByUIRef <- newIORef ""

368+ valueByUIRef :: IORef Text <- newIORef ""

265− valueRef <- newIORef ""

369+ valueRef :: IORef Text <- newIORef ""

266− setValueChan :: Chan Text <- newChan

370+ setValueChan :: Chan Text <- newChan

267− let checkValue = do

371+ let checkValue = do

268− liftIO $ readIORef valueByUIRef >>= flip shouldBe ""

372+ liftIO $ readIORef valueByUIRef >>= flip shouldBe ""

269− liftIO $ readIORef valueRef >>= flip shouldBe ""

373+ liftIO $ readIORef valueRef >>= flip shouldBe ""

270− e <- WD.findElem $ WD.ByTag "input"

374+ e <- WD.findElem $ WD.ByTag "input"

271− WD.sendKeys "hello" e

375+ WD.sendKeys "hello" e

272− liftIO $ do

376+ liftIO $ do

273− threadDelay 100000

377+ threadDelay 100000

274− readIORef valueByUIRef >>= flip shouldBe "hello"

378+ readIORef valueByUIRef >>= flip shouldBe "hello"

275− readIORef valueRef >>= flip shouldBe "hello"

379+ readIORef valueRef >>= flip shouldBe "hello"

276− writeChan setValueChan "world"

380+ writeChan setValueChan "world"

277− threadDelay 100000

381+ threadDelay 100000

278− readIORef valueByUIRef >>= flip shouldBe "hello"

382+ readIORef valueByUIRef >>= flip shouldBe "hello"

279− readIORef valueRef >>= flip shouldBe "world"

383+ readIORef valueRef >>= flip shouldBe "world"

280− testWidget (pure ()) checkValue $ do

384+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do

281− (setValue, triggerSetValue) <- newTriggerEvent

385+ (setValue, triggerSetValue) <- newTriggerEvent

282− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do

386+ prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do

283− triggerSetValue =<< readChan setValueChan

387+ triggerSetValue =<< readChan setValueChan

284− e <- inputElement $ def & inputElementConfig_setValue .~ setValue

388+ e <- inputElement $ def & inputElementConfig_setValue .~ setValue

285− performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e

389+ performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e

286− performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)

390+ performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)

287− it "sets checked appropriately" $ do

391+ it "sets checked appropriately" $ do

288− checkedByUIRef <- newIORef False

392+ checkedByUIRef <- newIORef False

289− checkedRef <- newIORef False

393+ checkedRef <- newIORef False

290− setCheckedChan <- newChan

394+ setCheckedChan <- newChan

291− let checkValue = do

395+ let checkValue = do

292− liftIO $ readIORef checkedByUIRef >>= flip shouldBe False

396+ liftIO $ readIORef checkedByUIRef >>= flip shouldBe False

293− liftIO $ readIORef checkedRef >>= flip shouldBe False

397+ liftIO $ readIORef checkedRef >>= flip shouldBe False

294− e <- WD.findElem $ WD.ByTag "input"

398+ e <- WD.findElem $ WD.ByTag "input"

295− WD.moveToCenter e

399+ WD.moveToCenter e

296− WD.click e

400+ WD.click e

297− liftIO $ do

401+ liftIO $ do

298− threadDelay 100000

402+ threadDelay 100000

299− readIORef checkedByUIRef >>= flip shouldBe True

403+ readIORef checkedByUIRef >>= flip shouldBe True

300− readIORef checkedRef >>= flip shouldBe True

404+ readIORef checkedRef >>= flip shouldBe True

301− writeChan setCheckedChan False

405+ writeChan setCheckedChan False

302− threadDelay 100000

406+ threadDelay 100000

303− readIORef checkedByUIRef >>= flip shouldBe True

407+ readIORef checkedByUIRef >>= flip shouldBe True

304− readIORef checkedRef >>= flip shouldBe False

408+ readIORef checkedRef >>= flip shouldBe False

305− testWidget (pure ()) checkValue $ do

409+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do

306− (setChecked, triggerSetChecked) <- newTriggerEvent

410+ (setChecked, triggerSetChecked) <- newTriggerEvent

307− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do

411+ prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do

308− triggerSetChecked =<< readChan setCheckedChan

412+ triggerSetChecked =<< readChan setCheckedChan

309− e <- inputElement $ def

413+ e <- inputElement $ def

310− & initialAttributes .~ "type" =: "checkbox"

414+ & initialAttributes .~ "type" =: "checkbox"

311− & inputElementConfig_setChecked .~ setChecked

415+ & inputElementConfig_setChecked .~ setChecked

312− performEvent_ $ liftIO . writeIORef checkedByUIRef <$> _inputElement_checkedChange e

416+ performEvent_ $ liftIO . writeIORef checkedByUIRef <$> _inputElement_checkedChange e

313− performEvent_ $ liftIO . writeIORef checkedRef <$> updated (_inputElement_checked e)

417+ performEvent_ $ liftIO . writeIORef checkedRef <$> updated (_inputElement_checked e)

314− it "captures file uploads" $ do

418+ it "captures file uploads" $ do

315− filesRef :: IORef [Text] <- newIORef []

419+ filesRef :: IORef [Text] <- newIORef []

316− let uploadFile = do

420+ let uploadFile = do

317− e <- WD.findElem $ WD.ByTag "input"

421+ e <- WD.findElem $ WD.ByTag "input"

318− path <- liftIO $ writeSystemTempFile "testFile" "file contents"

422+ path <- liftIO $ writeSystemTempFile "testFile" "file contents"

319− WD.sendKeys (T.pack path) e

423+ WD.sendKeys (T.pack path) e

320− WD.click <=< WD.findElem $ WD.ByTag "button"

424+ WD.click <=< WD.findElem $ WD.ByTag "button"

321− liftIO $ removeFile path

425+ liftIO $ removeFile path

322− input <- liftIO $ readIORef filesRef

426+ input <- liftIO $ readIORef filesRef

323− liftIO $ input `shouldBe` [T.pack $ FilePath.takeFileName path]

427+ liftIO $ input `shouldBe` [T.pack $ FilePath.takeFileName path]

324− testWidget (pure ()) uploadFile $ do

428+ testWidget (pure ()) uploadFile $ prerender (pure ()) $ do

325− e <- inputElement $ def & initialAttributes .~ "type" =: "file"

429+ e <- inputElement $ def & initialAttributes .~ "type" =: "file"

326− click <- button "save"

430+ click <- button "save"

327− prerender (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do

431+ prerender (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do

328− names <- liftJSM $ traverse File.getName fs

432+ names <- liftJSM $ traverse File.getName fs

329− liftIO $ writeIORef filesRef names

433+ liftIO $ writeIORef filesRef names

330

434

331 describe "prerender" $ parallel $ do

435 describe "prerender" $ parallel $ do

332 it "works in simple case" $ do

436 it "works in simple case" $ do

@@ -444,4 +548,5 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")

444 a <- beforeJS

548 a <- beforeJS

445 liftIO $ putMVar waitBeforeJS ()

549 liftIO $ putMVar waitBeforeJS ()

446 liftIO $ takeMVar waitUntilSwitchover

550 liftIO $ takeMVar waitUntilSwitchover

551+ liftIO $ threadDelay 100000 -- wait a bit

447 afterSwitchover a

552 afterSwitchover a