@@ -17,6 +17,7 @@ import Control.Monad.Fix
1717import Control.Monad.IO.Class
1818import Data.Foldable (traverse_)
1919import Data.IORef
20+import Data.Map (Map)
2021import Data.Maybe (fromMaybe)
2122import Data.Proxy
2223import Data.Text (Text)
@@ -42,8 +43,12 @@ import System.IO.Temp
4243import System.Directory
4344import qualified System.FilePath as FilePath
4445
46+import qualified GHCJS.DOM as DOM
47+import qualified GHCJS.DOM.Document as Document
48+import qualified GHCJS.DOM.Element as Element
4549import qualified GHCJS.DOM.EventM as EventM
4650import qualified GHCJS.DOM.GlobalEventHandlers as Events
51+import qualified GHCJS.DOM.Node as Node
4752import qualified Data.ByteString.Lazy as LBS
4853import qualified Data.Text as T
4954import qualified Data.Text.Encoding as TE
@@ -293,9 +298,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
293298 readIORef valueByUIRef >>= flip shouldBe "hello"
294299 readIORef valueRef >>= flip shouldBe "world"
295300 testWidget (pure ()) checkValue $ do
296− (setValue, triggerSetValue) <- newTriggerEvent
297− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
298− triggerSetValue =<< readChan setValueChan
301+ setValue <- triggerEventWithChan setValueChan
299302 e <- inputElement $ def & inputElementConfig_setValue .~ setValue
300303 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e
301304 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -318,9 +321,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
318321 readIORef checkedByUIRef >>= flip shouldBe True
319322 readIORef checkedRef >>= flip shouldBe False
320323 testWidget (pure ()) checkValue $ do
321− (setChecked, triggerSetChecked) <- newTriggerEvent
322− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
323− triggerSetChecked =<< readChan setCheckedChan
324+ setChecked <- triggerEventWithChan setCheckedChan
324325 e <- inputElement $ def
325326 & initialAttributes .~ "type" =: "checkbox"
326327 & inputElementConfig_setChecked .~ setChecked
@@ -384,9 +385,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
384385 readIORef valueByUIRef >>= flip shouldBe "hello"
385386 readIORef valueRef >>= flip shouldBe "world"
386387 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
387− (setValue, triggerSetValue) <- newTriggerEvent
388− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
389− triggerSetValue =<< readChan setValueChan
388+ setValue <- triggerEventWithChan setValueChan
390389 e <- inputElement $ def & inputElementConfig_setValue .~ setValue
391390 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e
392391 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -409,9 +408,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
409408 readIORef checkedByUIRef >>= flip shouldBe True
410409 readIORef checkedRef >>= flip shouldBe False
411410 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
412− (setChecked, triggerSetChecked) <- newTriggerEvent
413− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
414− triggerSetChecked =<< readChan setCheckedChan
411+ setChecked <- triggerEventWithChan setCheckedChan
415412 e <- inputElement $ def
416413 & initialAttributes .~ "type" =: "checkbox"
417414 & inputElementConfig_setChecked .~ setChecked
@@ -506,9 +503,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
506503 readIORef valueByUIRef >>= flip shouldBe "hello"
507504 readIORef valueRef >>= flip shouldBe "world"
508505 testWidget (pure ()) checkValue $ do
509− (setValue', triggerSetValue) <- newTriggerEvent
510− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
511− triggerSetValue =<< readChan setValueChan
506+ setValue' <- triggerEventWithChan setValueChan
512507 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
513508 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _textAreaElement_input e
514509 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -554,9 +549,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
554549 readIORef valueByUIRef >>= flip shouldBe "hello"
555550 readIORef valueRef >>= flip shouldBe "world"
556551 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
557− (setValue', triggerSetValue) <- newTriggerEvent
558− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
559− triggerSetValue =<< readChan setValueChan
552+ setValue' <- triggerEventWithChan setValueChan
560553 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
561554 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _textAreaElement_input e
562555 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -642,9 +635,7 @@ main = hspec $ beforeAll startSeleniumServer $ do
642635 readIORef valueByUIRef >>= flip shouldBe "two"
643636 readIORef valueRef >>= flip shouldBe "three"
644637 testWidget (pure ()) checkValue $ do
645− (setValue', triggerSetValue) <- newTriggerEvent
646− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
647− triggerSetValue =<< readChan setValueChan
638+ setValue' <- triggerEventWithChan setValueChan
648639 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
649640 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _selectElement_change e
650641 performEvent_ $ liftIO . writeIORef valueRef <$> updated (_selectElement_value e)
@@ -688,13 +679,89 @@ main = hspec $ beforeAll startSeleniumServer $ do
688679 readIORef valueByUIRef >>= flip shouldBe "two"
689680 readIORef valueRef >>= flip shouldBe "three"
690681 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
691− (setValue', triggerSetValue) <- newTriggerEvent
692− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
693− triggerSetValue =<< readChan setValueChan
682+ setValue' <- triggerEventWithChan setValueChan
694683 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
695684 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _selectElement_change e
696685 performEvent_ $ liftIO . writeIORef valueRef <$> updated (_selectElement_value e)
697686
687+ let createRawElement :: DOM.MonadJSM m => m DOM.Element
688+ createRawElement = do
689+ doc <- DOM.currentDocumentUnchecked
690+ div <- Document.createElement doc ("div" :: Text)
691+ Element.setAttribute div ("id" :: Text) ("raw" :: Text)
692+ text <- Document.createTextNode doc ("two" :: Text)
693+ Node.appendChild div text
694+ pure div
695+ describe "placeRawElement" $ do
696+ it "is placed correctly in the DOM at switchover" $ do
697+ let check = do
698+ shouldContainText "two" <=< WD.findElem $ WD.ByTag "div"
699+ shouldContainText "one\ntwo\nthree" <=< WD.findElem $ WD.ByTag "body"
700+ testWidget (pure ()) check $ do
701+ text "one"
702+ prerender (pure ()) $ placeRawElement =<< createRawElement
703+ text "three"
704+ it "is placed correctly in the DOM in immediate mode" $ do
705+ let check = do
706+ shouldContainText "two" <=< WD.findElem $ WD.ByTag "div"
707+ shouldContainText "one\ntwo\nthree" <=< WD.findElem $ WD.ByTag "body"
708+ testWidget (pure ()) check $ prerender (pure ()) $ do
709+ text "one"
710+ placeRawElement =<< createRawElement
711+ text "three"
712+ it "can be clicked" $ do
713+ clickedRef <- newIORef False
714+ let check = WD.click <=< WD.findElem $ WD.ByTag "div"
715+ testWidget (pure ()) check $ prerender (pure ()) $ do
716+ raw <- createRawElement
717+ placeRawElement raw
718+ let htmlElement = DOM.uncheckedCastTo DOM.HTMLElement raw
719+ liftJSM $ htmlElement `EventM.on` Events.click $ do
720+ liftIO $ writeIORef clickedRef True
721+ return ()
722+ clicked <- readIORef clickedRef
723+ assertEqual "Not clicked" True clicked
724+
725+ describe "wrapRawElement" $ do
726+ it "modifies attributes" $ do
727+ modifyAttrsChan :: Chan (Map AttributeName (Maybe Text)) <- newChan
728+ let check = do
729+ div <- WD.findElem $ WD.ByTag "div"
730+ assertAttr div "test" Nothing
731+ liftIO $ writeChan modifyAttrsChan ("test" =: Just "test")
732+ assertAttr div "test" (Just "test")
733+ testWidget (pure ()) check $ prerender (pure ()) $ do
734+ modifyAttrs <- triggerEventWithChan modifyAttrsChan
735+ raw <- createRawElement
736+ placeRawElement raw
737+ wrapRawElement raw $ RawElementConfig
738+ { _rawElementConfig_modifyAttributes = Just modifyAttrs
739+ , _rawElementConfig_eventSpec = (def :: EventSpec GhcjsDomSpace EventResult)
740+ }
741+ return ()
742+ it "works with eventFlags" $ do
743+ clickedRef <- newIORef False
744+ let clickBoth = do
745+ liftIO $ readIORef clickedRef >>= flip shouldBe False
746+ WD.findElem (WD.ById "normal") >>= WD.click
747+ liftIO $ do
748+ readIORef clickedRef >>= flip shouldBe True
749+ writeIORef clickedRef False
750+ WD.findElem (WD.ById "raw") >>= WD.click
751+ liftIO $ do
752+ threadDelay 100000
753+ readIORef clickedRef >>= flip shouldBe False
754+ testWidget (pure ()) clickBoth $ prerender (pure ()) $ do
755+ (e, _) <- el' "div" $ do
756+ raw <- createRawElement
757+ placeRawElement raw
758+ wrapRawElement raw $ RawElementConfig
759+ { _rawElementConfig_modifyAttributes = Nothing
760+ , _rawElementConfig_eventSpec = addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> stopPropagation) (def :: EventSpec GhcjsDomSpace EventResult)
761+ }
762+ elAttr "div" ("id" =: "normal") $ text "normal"
763+ performEvent_ $ liftIO (writeIORef clickedRef True) <$ domEvent Click e
764+
698765 describe "prerender" $ do
699766 it "works in simple case" $ do
700767 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
@@ -736,6 +803,12 @@ startSeleniumServer = do
736803 _ <- forkIO $ print =<< waitForProcess ph
737804 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
738805
806+triggerEventWithChan :: (TriggerEvent t m, Prerender js m) => Chan a -> m (Event t a)
807+triggerEventWithChan chan = do
808+ (e, trigger) <- newTriggerEvent
809+ prerender (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
810+ pure e
811+
739812assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
740813assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
741814
@@ -746,21 +819,17 @@ elementShouldBeRemoved e = do
746819 Left e -> throwM e
747820 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
748821
749−shouldContainText :: WD.Element -> Text -> WD ()
750−shouldContainText e t = liftIO . flip shouldBe t =<< WD.getText e
822+shouldContainText :: Text -> WD.Element -> WD ()
823+shouldContainText t = liftIO . flip shouldBe t <=< WD.getText
751824
752825checkBodyText :: Text -> WD ()
753826checkBodyText = checkTextInTag "body"
754827
755828checkTextInTag :: Text -> Text -> WD ()
756−checkTextInTag tag expected = do
757− body <- WD.findElem $ WD.ByTag tag
758− body `shouldContainText` expected
829+checkTextInTag tag expected = WD.findElem (WD.ByTag tag) >>= shouldContainText expected
759830
760831checkTextInId :: Text -> Text -> WD ()
761−checkTextInId i expected = do
762− e <- WD.findElem $ WD.ById i
763− e `shouldContainText` expected
832+checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
764833
765834divId :: DomBuilder t m => Text -> m a -> m a
766835divId i = elAttr "div" ("id" =: i)