git.iko.soy/reflex-dom
on develop help sign in
test runWithReplace and traverseDMapWithKeyWithKeyWithAdjust
c734984Tom Smalley
reflex-dom-core/reflex-dom-core.cabal+5
compare with develop
unifiedsplit
@@ -155,7 +155,12 @@ test-suite hydration
155 build-depends: base
155 build-depends: base
156 , aeson
156 , aeson
157 , bytestring
157 , bytestring
158+ , constraints
159+ , constraints-extras
158 , containers
160 , containers
161+ , dependent-map
162+ , dependent-sum
163+ , dependent-sum-template
159 , directory
164 , directory
160 , exceptions
165 , exceptions
161 , filepath
166 , filepath
reflex-dom-core/test/hydration.hs+316−23
@@ -2,68 +2,113 @@
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE GADTs #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
11
15
12import Control.Concurrent
16import Control.Concurrent
13−import Control.Lens ((^.))
14import Control.Monad
17import Control.Monad
15import Control.Monad.Catch
18import Control.Monad.Catch
16import Control.Monad.Fix
19import Control.Monad.Fix
17import Control.Monad.IO.Class
20import Control.Monad.IO.Class
21+import Data.Constraint (Dict(..))
22+import Data.Constraint.Extras
23+import Data.Dependent.Map (DMap)
24+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
18import Data.Foldable (traverse_)
25import Data.Foldable (traverse_)
26+import Data.Functor.Identity
27+import Data.Functor.Misc
28+import Data.GADT.Compare.TH
29+import Data.GADT.Show.TH
19import Data.IORef
30import Data.IORef
20import Data.Map (Map)
31import Data.Map (Map)
21−import Data.Maybe (fromMaybe)
32+import Data.Maybe (fromMaybe, fromJust)
22import Data.Proxy
33import Data.Proxy
23import Data.Text (Text)
34import Data.Text (Text)
24−import Language.Javascript.JSaddle (JSException(..), syncPoint, liftJSM, jsg, js1)
35+import Language.Javascript.JSaddle (syncPoint, liftJSM)
25import Language.Javascript.JSaddle.Warp
36import Language.Javascript.JSaddle.Warp
26import Network.HTTP.Types (status200)
37import Network.HTTP.Types (status200)
27import Network.Wai
38import Network.Wai
28import Network.WebSockets
39import Network.WebSockets
29−import Reflex.Dom.Core
30import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
40import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
41+import Reflex.Dom.Core
42+import System.Directory
43+import System.IO (stderr)
44+import System.IO.Silently
45+import System.IO.Temp
31import System.Process
46import System.Process
32−import System.Random
33import System.Timeout
47import System.Timeout
34−import Test.Hspec
35import Test.HUnit
48import Test.HUnit
49+import Test.Hspec
36import Test.WebDriver (WD)
50import Test.WebDriver (WD)
37−import qualified GHCJS.DOM.Types as DOM
38−import qualified GHCJS.DOM.File as File
39−
40−import System.IO (stderr)
41−import System.IO.Silently
42−import System.IO.Temp
43−import System.Directory
44−import qualified System.FilePath as FilePath
45
51
52+import qualified Data.ByteString.Lazy as LBS
53+import qualified Data.Dependent.Map as DMap
54+import qualified Data.Text as T
55+import qualified Data.Text.Encoding as TE
46import qualified GHCJS.DOM as DOM
56import qualified GHCJS.DOM as DOM
47import qualified GHCJS.DOM.Document as Document
57import qualified GHCJS.DOM.Document as Document
48import qualified GHCJS.DOM.Element as Element
58import qualified GHCJS.DOM.Element as Element
49import qualified GHCJS.DOM.EventM as EventM
59import qualified GHCJS.DOM.EventM as EventM
60+import qualified GHCJS.DOM.File as File
50import qualified GHCJS.DOM.GlobalEventHandlers as Events
61import qualified GHCJS.DOM.GlobalEventHandlers as Events
51import qualified GHCJS.DOM.Node as Node
62import qualified GHCJS.DOM.Node as Node
52−import qualified Data.ByteString.Lazy as LBS
63+import qualified GHCJS.DOM.Types as DOM
53−import qualified Data.Text as T
54−import qualified Data.Text.Encoding as TE
55import qualified Network.Wai.Handler.Warp as Warp
64import qualified Network.Wai.Handler.Warp as Warp
65+import qualified System.FilePath as FilePath
56import qualified Test.WebDriver as WD
66import qualified Test.WebDriver as WD
57
67
58testTimeLimit :: Int
68testTimeLimit :: Int
59−testTimeLimit = 1 * 1000 * 1000
69+testTimeLimit = 3 * 1000 * 1000
60
70
61chromeConfig :: WD.WDConfig
71chromeConfig :: WD.WDConfig
62chromeConfig = WD.useBrowser (WD.chrome { WD.chromeBinary = Just "/run/current-system/sw/bin/chromium", WD.chromeOptions = ["--headless"]}) WD.defaultConfig
72chromeConfig = WD.useBrowser (WD.chrome { WD.chromeBinary = Just "/run/current-system/sw/bin/chromium", WD.chromeOptions = ["--headless"]}) WD.defaultConfig
63
73
64−-- TODO list
74+keyMap :: DMap DKey Identity
65−-- use only available ports
75+keyMap = DMap.fromList
66−-- parallel (requires port fix)
76+ [ Key_Int ==> 0
77+ , Key_Char ==> 'A'
78+ ]
79+
80+data DKey a where
81+ Key_Int :: DKey Int
82+ Key_Char :: DKey Char
83+ Key_Bool :: DKey Bool
84+
85+instance ArgDict DKey where
86+ type ConstraintsFor DKey c = (c Int, c Char, c Bool)
87+ argDict = \case
88+ Key_Int -> Dict
89+ Key_Char -> Dict
90+ Key_Bool -> Dict
91+
92+textKey :: DKey a -> Text
93+textKey = \case
94+ Key_Int -> "Key_Int"
95+ Key_Char -> "Key_Char"
96+ Key_Bool -> "Key_Bool"
97+
98+deriveGEq ''DKey
99+deriveGCompare ''DKey
100+deriveGShow ''DKey
101+
102+instance ShowTag DKey Identity where
103+ showTaggedPrec = \case
104+ Key_Int -> showsPrec
105+ Key_Char -> showsPrec
106+ Key_Bool -> showsPrec
107+
108+instance EqTag DKey Identity where
109+ eqTagged Key_Int Key_Int = (==)
110+ eqTagged Key_Char Key_Char = (==)
111+ eqTagged Key_Bool Key_Bool = (==)
67
112
68main :: IO ()
113main :: IO ()
69main = hspec $ beforeAll startSeleniumServer $ do
114main = hspec $ beforeAll startSeleniumServer $ do
@@ -134,7 +179,6 @@ main = hspec $ beforeAll startSeleniumServer $ do
134 testWidgetStatic (pure ()) $ do
179 testWidgetStatic (pure ()) $ do
135 text =<< prerender (pure "One") (pure "Two")
180 text =<< prerender (pure "One") (pure "Two")
136
181
137−
138 describe "element" $ do
182 describe "element" $ do
139 it "works with domEvent Click" $ do
183 it "works with domEvent Click" $ do
140 clickedRef <- newIORef False
184 clickedRef <- newIORef False
@@ -796,12 +840,247 @@ main = hspec $ beforeAll startSeleniumServer $ do
796 )
840 )
797 (traverse_ elementShouldBeRemoved)
841 (traverse_ elementShouldBeRemoved)
798 (el "span" $ prerender (text "One") (text "Two"))
842 (el "span" $ prerender (text "One") (text "Two"))
843+-- it "postBuild works on server side" $ do
844+-- pbRef <- newIORef False
845+-- testWidgetStatic (pure ()) $ do
846+-- prerender (do
847+-- pb <- getPostBuild
848+-- performEvent_ $ liftIO (writeIORef pbRef True) <$ pb) blank
849+-- readIORef pbRef >>= (`shouldBe` True)
850+ it "postBuild works on client side" $ do
851+ pbRef <- newIORef False
852+ testWidgetStatic (pure ()) $ do
853+ prerender blank $ do
854+ pb <- getPostBuild
855+ performEvent_ $ liftIO (writeIORef pbRef True) <$ pb
856+ readIORef pbRef >>= (`shouldBe` True)
857+
858+ describe "runWithReplace" $ do
859+ it "works" $ do
860+ replaceChan <- newChan
861+ let setup = WD.findElem $ WD.ByTag "div"
862+ check ssr = do
863+ -- Check that the original element still exists and has the correct text
864+ WD.getText ssr >>= liftIO . flip shouldBe "two"
865+ liftIO $ do
866+ writeChan replaceChan "three"
867+ threadDelay 100000
868+ elementShouldBeRemoved ssr
869+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
870+ testWidget' setup check $ do
871+ replace <- triggerEventWithChan replaceChan
872+ pb <- getPostBuild
873+ runWithReplace (el "div" $ text "one") $ leftmost
874+ [ el "div" (text "two") <$ pb
875+ , el "span" . text <$> replace
876+ ]
877+ return ()
878+ it "can be nested in initial widget" $ do
879+ replaceChan <- newChan
880+ let setup = WD.findElem $ WD.ByTag "div"
881+ check ssr = do
882+ -- Check that the original element still exists and has the correct text
883+ WD.getText ssr >>= liftIO . flip shouldBe "two"
884+ liftIO $ do
885+ writeChan replaceChan "three"
886+ threadDelay 100000
887+ elementShouldBeRemoved ssr
888+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
889+ testWidget' setup check $ void $ flip runWithReplace never $ do
890+ replace <- triggerEventWithChan replaceChan
891+ pb <- getPostBuild
892+ runWithReplace (el "div" $ text "one") $ leftmost
893+ [ el "div" (text "two") <$ pb
894+ , el "span" . text <$> replace
895+ ]
896+ return ()
897+ it "can be nested in postBuild widget" $ do
898+ replaceChan <- newChan
899+ let setup = WD.findElem $ WD.ByTag "div"
900+ check ssr = do
901+ -- Check that the original element still exists and has the correct text
902+ WD.getText ssr >>= liftIO . flip shouldBe "two"
903+ liftIO $ do
904+ writeChan replaceChan "three"
905+ threadDelay 100000
906+ elementShouldBeRemoved ssr
907+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
908+ testWidget' setup check $ void $ do
909+ pb <- getPostBuild
910+ runWithReplace (pure ()) $ ffor pb $ \() -> do
911+ replace <- triggerEventWithChan replaceChan
912+ pb <- getPostBuild
913+ runWithReplace (el "div" $ text "one") $ leftmost
914+ [ el "div" (text "two") <$ pb
915+ , el "span" . text <$> replace
916+ ]
917+ return ()
918+ it "can be nested in event widget" $ do
919+ replaceChan1 <- newChan
920+ replaceChan2 <- newChan
921+ let check = do
922+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
923+ liftIO $ do
924+ writeChan replaceChan1 "one"
925+ threadDelay 100000
926+ one <- WD.findElem $ WD.ByTag "div"
927+ WD.getText one >>= liftIO . flip shouldBe "pb"
928+ liftIO $ do
929+ writeChan replaceChan2 "two"
930+ threadDelay 100000
931+ elementShouldBeRemoved one
932+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
933+ testWidget (pure ()) check $ void $ do
934+ replace1 <- triggerEventWithChan replaceChan1
935+ runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
936+ replace2 <- triggerEventWithChan replaceChan2
937+ pb <- getPostBuild
938+ runWithReplace (el "div" $ text r1) $ leftmost
939+ [ el "span" . text <$> replace2
940+ , el "div" (text "pb") <$ pb
941+ ]
942+ return ()
943+ it "works in immediate mode (RHS of prerender)" $ do
944+ replaceChan :: Chan Text <- newChan
945+ let check = do
946+ one <- WD.findElem $ WD.ByTag "div"
947+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
948+ WD.getText one >>= liftIO . flip shouldBe "one"
949+ liftIO $ do
950+ writeChan replaceChan "pb"
951+ threadDelay 100000
952+ elementShouldBeRemoved one
953+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
954+ testWidget (pure ()) check $ void $ do
955+ prerender blank $ do
956+ replace <- triggerEventWithChan replaceChan
957+ pb <- getPostBuild
958+ void $ runWithReplace (el "div" $ text "one") $ el "span" . text <$> replace
959+ it "works with postBuild in immediate mode (RHS of prerender)" $ do
960+ replaceChan :: Chan Text <- newChan
961+ let check = do
962+ two <- WD.findElem $ WD.ByTag "div"
963+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
964+ WD.getText two >>= liftIO . flip shouldBe "two"
965+ liftIO $ do
966+ writeChan replaceChan "three"
967+ threadDelay 100000
968+ elementShouldBeRemoved two
969+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
970+ testWidget (pure ()) check $ void $ do
971+ prerender blank $ do
972+ replace <- triggerEventWithChan replaceChan
973+ pb <- getPostBuild
974+ void $ runWithReplace (el "div" $ text "one") $ leftmost
975+ [ el "div" (text "two") <$ pb
976+ , el "span" . text <$> replace
977+ ]
978+
979+ describe "traverseDMapWithKeyWithAdjust" $ do
980+ let widget :: TestWidget js t m => DKey a -> Identity a -> m (Identity a)
981+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
982+ elClass "span" "key" $ text $ textKey k
983+ elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
984+ pure (Identity v)
985+ checkItem :: WD.Element -> Text -> Text -> WD ()
986+ checkItem li k v = do
987+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
988+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
989+ checkInitialItems dm xs = do
990+ liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
991+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
992+ getAndCheckInitialItems dm = do
993+ xs <- WD.findElems (WD.ByTag "li")
994+ checkInitialItems dm xs
995+ pure xs
996+ checkRemoval chan k = do
997+ e <- WD.findElem (WD.ById $ textKey k)
998+ liftIO $ do
999+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
1000+ threadDelay 100000
1001+ elementShouldBeRemoved e
1002+ checkReplace chan k v = do
1003+ e <- WD.findElem (WD.ById $ textKey k)
1004+ liftIO $ do
1005+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1006+ threadDelay 100000
1007+ elementShouldBeRemoved e
1008+ e' <- WD.findElem (WD.ById $ textKey k)
1009+ checkItem e' (textKey k) (T.pack $ show v)
1010+ checkInsert chan k v = do
1011+ liftIO $ do
1012+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1013+ threadDelay 100000
1014+ e <- WD.findElem (WD.ById $ textKey k)
1015+ checkItem e (textKey k) (T.pack $ show v)
1016+ postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1017+ it "doesn't replace elements at switchover, can delete/update/insert" $ do
1018+ chan <- newChan
1019+ let static = getAndCheckInitialItems keyMap
1020+ check xs = do
1021+ checkInitialItems keyMap xs
1022+ checkRemoval chan Key_Int
1023+ checkReplace chan Key_Char 'B'
1024+ checkInsert chan Key_Bool True
1025+ testWidget' static check $ void $ do
1026+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1027+ liftIO $ dmap `shouldBe` keyMap
1028+ it "handles postBuild correctly" $ do
1029+ chan <- newChan
1030+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1031+ check xs = do
1032+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
1033+ checkRemoval chan Key_Int
1034+ checkInsert chan Key_Char 'B'
1035+ checkReplace chan Key_Bool True
1036+ testWidget' static check $ void $ do
1037+ pb <- getPostBuild
1038+ replace <- triggerEventWithChan chan
1039+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1040+ liftIO $ dmap `shouldBe` keyMap
1041+ it "can delete/update/insert when built in prerender" $ do
1042+ chan <- newChan
1043+ let check = do
1044+ getAndCheckInitialItems keyMap
1045+ checkRemoval chan Key_Int
1046+ checkReplace chan Key_Char 'B'
1047+ checkInsert chan Key_Bool True
1048+ testWidget (pure ()) check $ prerender (pure ()) $ void $ do
1049+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1050+ liftIO $ dmap `shouldBe` keyMap
1051+ it "can delete/update/insert when built in immediate mode" $ do
1052+ chan <- newChan
1053+ let check = do
1054+ getAndCheckInitialItems keyMap
1055+ checkRemoval chan Key_Int
1056+ checkReplace chan Key_Char 'B'
1057+ checkInsert chan Key_Bool True
1058+ testWidget (pure ()) check $ void $ do
1059+ pb <- getPostBuild
1060+ runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1061+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1062+ liftIO $ dmap `shouldBe` keyMap
1063+ -- Should be fixed by prerender changes!
1064+ it "handles postBuild correctly in prerender" $ do
1065+ chan <- newChan
1066+ let check = do
1067+ getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1068+ checkRemoval chan Key_Int
1069+ checkInsert chan Key_Char 'B'
1070+ checkReplace chan Key_Bool True
1071+ testWidget (pure ()) check $ do
1072+ replace <- triggerEventWithChan chan
1073+ prerender (pure ()) $ void $ do
1074+ pb <- getPostBuild
1075+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1076+ liftIO $ dmap `shouldBe` keyMap
799
1077
800startSeleniumServer :: IO ()
1078startSeleniumServer :: IO ()
801startSeleniumServer = do
1079startSeleniumServer = do
802 (_,_,_,ph) <- createProcess $ (proc "selenium-server" [])
1080 (_,_,_,ph) <- createProcess $ (proc "selenium-server" [])
803 { std_in = NoStream
1081 { std_in = NoStream
804 , std_out = NoStream
1082 , std_out = NoStream
1083+ , std_err = NoStream
805 }
1084 }
806 _ <- forkIO $ print =<< waitForProcess ph
1085 _ <- forkIO $ print =<< waitForProcess ph
807 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
1086 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
@@ -837,7 +1116,7 @@ checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expecte
837divId :: DomBuilder t m => Text -> m a -> m a
1116divId :: DomBuilder t m => Text -> m a -> m a
838divId i = elAttr "div" ("id" =: i)
1117divId i = elAttr "div" ("id" =: i)
839
1118
840−type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m, MonadIO m)
1119+type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadFix m, MonadIO m)
841
1120
842testWidgetStatic
1121testWidgetStatic
843 :: WD b
1122 :: WD b
@@ -894,3 +1173,17 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")
894 liftIO $ takeMVar waitUntilSwitchover
1173 liftIO $ takeMVar waitUntilSwitchover
895 liftIO $ threadDelay 100000 -- wait a bit
1174 liftIO $ threadDelay 100000 -- wait a bit
896 afterSwitchover a
1175 afterSwitchover a
1176+
1177+testWidgetDebug :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> IO ()
1178+testWidgetDebug bodyWidget = do
1179+ let staticApp = do
1180+ el "head" $ pure ()
1181+ el "body" $ do
1182+ bodyWidget
1183+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1184+ ((), html) <- renderStatic staticApp
1185+ let entryPoint = do
1186+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) $ bodyWidget
1187+ syncPoint
1188+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1189+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application