@@ -39,6 +39,7 @@ import Network.Wai
3939import Network.WebSockets
4040import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
4141import Reflex.Dom.Core
42+import Reflex.Patch.DMapWithMove
4243import System.Directory
4344import System.IO (stderr)
4445import System.IO.Silently
@@ -838,7 +839,6 @@ tests _selenium = do
838839 let check = do
839840 liftIO $ do
840841 writeChan replaceChan ()
841− threadDelay 100000
842842 takeMVar pbLock
843843 testWidget (pure ()) check $ void $ do
844844 replace <- triggerEventWithChan replaceChan
@@ -853,7 +853,6 @@ tests _selenium = do
853853 shouldContainText "" =<< WD.findElem (WD.ByTag "body")
854854 liftIO $ do
855855 writeChan replaceChan1 "one"
856− threadDelay 100000
857856 takeMVar lock
858857 one <- WD.findElem $ WD.ByTag "div"
859858 WD.getText one >>= liftIO . flip shouldBe "pb"
@@ -1115,6 +1114,102 @@ tests _selenium = do
11151114 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
11161115 liftIO $ dmap `shouldBe` intMap
11171116
1117+ describe "traverseDMapWithKeyWithAdjustWithMove" $ do
1118+ let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1119+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1120+ elClass "span" "key" $ text $ textKey k
1121+ elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
1122+ pure (Identity v)
1123+ textKey :: Key2 a -> Text
1124+ textKey = \case
1125+ Key2_Int i -> "i" <> T.pack (show i)
1126+ Key2_Char c -> "c" <> T.pack [c]
1127+ checkItem :: WD.Element -> Text -> Text -> WD ()
1128+ checkItem li k v = do
1129+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1130+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1131+ checkInitialItems dm xs = do
1132+ liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1133+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1134+ getAndCheckInitialItems dm = do
1135+ xs <- WD.findElems (WD.ByTag "li")
1136+ checkInitialItems dm xs
1137+ pure xs
1138+ checkRemoval chan k = do
1139+ e <- WD.findElem (WD.ById $ textKey k)
1140+ liftIO $ do
1141+ writeChan chan $ deleteDMapKey k
1142+ threadDelay 100000
1143+ elementShouldBeRemoved e
1144+ checkReplace chan k v = do
1145+ e <- WD.findElem (WD.ById $ textKey k)
1146+ liftIO $ do
1147+ writeChan chan $ insertDMapKey k (Identity v)
1148+ threadDelay 100000
1149+ elementShouldBeRemoved e
1150+ e' <- WD.findElem (WD.ById $ textKey k)
1151+ checkItem e' (textKey k) (T.pack $ show v)
1152+ checkInsert chan k v = do
1153+ liftIO $ do
1154+ writeChan chan $ insertDMapKey k (Identity v)
1155+ threadDelay 100000
1156+ e <- WD.findElem (WD.ById $ textKey k)
1157+ checkItem e (textKey k) (T.pack $ show v)
1158+ moveSpec testMove = do
1159+ it "can insert an item" $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1160+ shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
1161+ liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2)
1162+ shouldContainText (T.strip $ T.unlines ["i11","i22","i33"]) body
1163+ it "can delete an item" $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3]) $ \body chan -> do
1164+ shouldContainText (T.strip $ T.unlines ["i11","i22","i33"]) body
1165+ liftIO $ writeChan chan (deleteDMapKey (Key2_Int 2))
1166+ shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
1167+ it "can swap items" $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
1168+ shouldContainText (T.strip $ T.unlines ["i11","i22","i33","i44"]) body
1169+ liftIO $ writeChan chan (swapDMapKey (Key2_Int 2) (Key2_Int 3))
1170+ shouldContainText (T.strip $ T.unlines ["i11","i33","i22","i44"]) body
1171+ it "can move items" $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
1172+ shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body
1173+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))
1174+ shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1175+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete
1176+ shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1177+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too
1178+ shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1179+ 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
1180+ shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1181+
1182+ describe "hydration" $ moveSpec $ \initMap test -> do
1183+ chan <- newChan
1184+ let static = getAndCheckInitialItems initMap
1185+ check xs = do
1186+ checkInitialItems initMap xs
1187+ body <- WD.findElem (WD.ByTag "body")
1188+ test body chan
1189+ testWidget' static check $ void $ do
1190+ (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1191+ liftIO $ dmap `shouldBe` initMap
1192+
1193+ describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1194+ chan <- newChan
1195+ replace <- newChan
1196+ lock <- newEmptyMVar
1197+ let check = do
1198+ liftIO $ do
1199+ writeChan replace ()
1200+ takeMVar lock
1201+ xs <- getAndCheckInitialItems initMap
1202+ checkInitialItems initMap xs
1203+ body <- WD.findElem (WD.ByTag "body")
1204+ test body chan
1205+ testWidget (pure ()) check $ void $ do
1206+ e <- triggerEventWithChan replace
1207+ runWithReplace (pure ()) $ ffor e $ \() -> void $ do
1208+ pb <- getPostBuild
1209+ performEvent_ $ liftIO (putMVar lock ()) <$ pb
1210+ (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1211+ liftIO $ dmap `shouldBe` initMap
1212+
11181213data Selenium = Selenium
11191214 { _selenium_portNumber :: PortNumber
11201215 , _selenium_stopServer :: IO ()
@@ -1253,3 +1348,26 @@ testWidgetDebug bodyWidget = do
12531348 syncPoint
12541349 application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
12551350 Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
1351+
1352+data Key2 a where
1353+ Key2_Int :: Int -> Key2 Int
1354+ Key2_Char :: Char -> Key2 Char
1355+
1356+deriveGEq ''Key2
1357+deriveGCompare ''Key2
1358+deriveGShow ''Key2
1359+
1360+instance ShowTag Key2 Identity where
1361+ showTaggedPrec = \case
1362+ Key2_Int _ -> showsPrec
1363+ Key2_Char _ -> showsPrec
1364+
1365+instance EqTag Key2 Identity where
1366+ eqTagged (Key2_Int _) (Key2_Int _) = (==)
1367+ eqTagged (Key2_Char _) (Key2_Char _) = (==)
1368+
1369+instance ArgDict Key2 where
1370+ type ConstraintsFor Key2 c = (c Int, c Char)
1371+ argDict = \case
1372+ Key2_Int _ -> Dict
1373+ Key2_Char _ -> Dict