b069848 · reflex-dom · git.iko.soy

39import Network.WebSockets

40import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)

41import Reflex.Dom.Core

42+import Reflex.Patch.DMapWithMove

42import System.Directory

43import System.Directory

43import System.IO (stderr)

44import System.IO (stderr)

44import System.IO.Silently

45import System.IO.Silently

838 let check = do

839 let check = do

839 liftIO $ do

840 liftIO $ do

840 writeChan replaceChan ()

841 writeChan replaceChan ()

841− threadDelay 100000

842 takeMVar pbLock

843 testWidget (pure ()) check $ void $ do

844 replace <- triggerEventWithChan replaceChan

853 shouldContainText "" =<< WD.findElem (WD.ByTag "body")

854 liftIO $ do

855 writeChan replaceChan1 "one"

856− threadDelay 100000

857 takeMVar lock

856 takeMVar lock

858 one <- WD.findElem $ WD.ByTag "div"

857 one <- WD.findElem $ WD.ByTag "div"

859 WD.getText one >>= liftIO . flip shouldBe "pb"

858 WD.getText one >>= liftIO . flip shouldBe "pb"

1115 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]

1114 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]

1116 liftIO $ dmap `shouldBe` intMap

1115 liftIO $ dmap `shouldBe` intMap

1117

1116

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+

1118data Selenium = Selenium

1213data Selenium = Selenium

1119 { _selenium_portNumber :: PortNumber

1214 { _selenium_portNumber :: PortNumber

1120 , _selenium_stopServer :: IO ()

1215 , _selenium_stopServer :: IO ()

1253 syncPoint

1348 syncPoint

1254 application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html

1349 application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html

1255 Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application

1350 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