886a123 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'develop' into avoid-run-with-replace-when-hydrating

886a123Elliot Cameron7 years ago

reflex-dom-core/ChangeLog.md+13

compare with develop

unifiedsplit

@@ -6,6 +6,19 @@

7* Fix attribute support for explicitly namespaced elements

9+* Remove deprecation warnings for the following widgets in

10+ `Reflex.Dom.Widget.Basic`:

11+

12+ * `Link`

13+ * `button`

14+ * `dtdd`

15+ * `linkClass`

16+ * `link`

17+ * `tabDisplay`

18+ * `tableDynAttr`

19+

20+* Fix bug in hydration when dealing with unexpected HTML ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)).

21+

9## 0.5.3

22## 0.5.3

11* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:

24* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:

reflex-dom-core/reflex-dom-core.cabal+1

@@ -166,6 +166,7 @@ test-suite hlint

166test-suite hydration

167 build-depends: base

168 , aeson

169+ , async

169 , bytestring

170 , bytestring

170 , chrome-test-utils

171 , chrome-test-utils

171 , constraints

172 , constraints

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+29−22

@@ -1271,8 +1271,8 @@ hydrateComment doc t mSetContents = do

1271skipToAndReplaceComment

1272 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)

1273 => Text

1274− -> IORef Text

1274+ -> IORef (Maybe Text)

1275− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

1275+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))

1276skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1277 HydrationMode_Immediate -> do

1278 -- If we're in immediate mode, we don't try to replace an existing comment,

@@ -1280,43 +1280,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1280 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

1281 append $ toNode t

1282 textNodeRef <- liftIO $ newIORef t

1283− keyRef <- liftIO $ newIORef ""

1283+ keyRef <- liftIO $ newIORef Nothing

1284 pure (pure (), textNodeRef, keyRef)

1285 HydrationMode_Hydrating -> do

1286 doc <- askDocument

1287 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"

1288 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"

1289+ let

1290+ go Nothing _ = do

1291+ tn <- createTextNode doc ("" :: Text)

1292+ insertAfterPreviousNode tn

1293+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }

1294+ pure (tn, Nothing)

1289− let go key0 mLastNode = do

1295+ go (Just key0) mLastNode = do

1290− parent <- askParent

1296+ parent <- askParent

1291− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

1297+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case

1298+ Nothing -> go Nothing Nothing

1292− DOM.castTo DOM.Comment node >>= \case

1299+ Just node -> DOM.castTo DOM.Comment node >>= \case

1293 Just comment -> do

1300 Just comment -> do

1294− commentText <- Node.getTextContentUnchecked comment

1301+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment

1295− case T.stripPrefix (prefix <> key0) commentText of

1302+ case T.stripPrefix (prefix <> key0) commentText of -- 'key0' may be @""@ in which case we're just finding the actual key; TODO: Don't be clever.

1296 Just key -> do

1303 Just key -> do

1297 -- Replace the comment with an (invisible) text node

1304 -- Replace the comment with an (invisible) text node

1298 tn <- createTextNode doc ("" :: Text)

1305 tn <- createTextNode doc ("" :: Text)

1299 Node.replaceChild_ parent tn comment

1306 Node.replaceChild_ parent tn comment

1300− pure (tn, key)

1307+ pure (tn, Just key)

1301 Nothing -> do

1308 Nothing -> do

1302− go key0 (Just node)

1309+ go (Just key0) (Just node)

1303 Nothing -> do

1310 Nothing -> do

1304− go key0 (Just node)

1311+ go (Just key0) (Just node)

1305− switchComment = do

1312+ switchComment = do

1306− key0 <- liftIO $ readIORef key0Ref

1313+ key0 <- liftIO $ readIORef key0Ref

1307− (tn, key) <- go key0 =<< getPreviousNode

1314+ (tn, key) <- go key0 =<< getPreviousNode

1308− setPreviousNode $ Just $ toNode tn

1315+ setPreviousNode $ Just $ toNode tn

1309− liftIO $ do

1316+ liftIO $ do

1310− writeIORef textNodeRef tn

1317+ writeIORef textNodeRef tn

1311− writeIORef keyRef key

1318+ writeIORef keyRef key

1312 pure (switchComment, textNodeRef, keyRef)

1319 pure (switchComment, textNodeRef, keyRef)

1313

1320

1314{-# INLINABLE skipToReplaceStart #-}

1321{-# INLINABLE skipToReplaceStart #-}

1315−skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

1322+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))

1316−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")

1323+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.

1317

1324

1318{-# INLINABLE skipToReplaceEnd #-}

1325{-# INLINABLE skipToReplaceEnd #-}

1319−skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)

1326+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef (Maybe Text) -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)

1320skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

1327skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

1321

1328

1322instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

1329instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+12−9

@@ -55,7 +55,6 @@ import Reflex.PerformEvent.Class

55import Reflex.PostBuild.Base

56import Reflex.PostBuild.Class

57import Reflex.TriggerEvent.Class

58−import System.Random (randomRIO)

60data StaticDomBuilderEnv t = StaticDomBuilderEnv

59data StaticDomBuilderEnv t = StaticDomBuilderEnv

61 { _staticDomBuilderEnv_shouldEscape :: Bool

60 { _staticDomBuilderEnv_shouldEscape :: Bool

@@ -64,6 +63,7 @@ data StaticDomBuilderEnv t = StaticDomBuilderEnv

64 -- We use this to add a "selected" attribute to the appropriate "option" child element.

63 -- We use this to add a "selected" attribute to the appropriate "option" child element.

65 -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.

64 -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.

66 -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.

65 -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.

66+ , _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int

67 }

69newtype StaticDomBuilderT t m a = StaticDomBuilderT

@@ -164,7 +164,7 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilde

164instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where

165 runWithReplace a0 a' = do

166 e <- StaticDomBuilderT ask

167− key <- replaceStart

167+ key <- replaceStart e

168 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

169 o <- hold (snd result0) $ fmapCheap snd result'

170 StaticDomBuilderT $ modify $ (:) $ join o

@@ -174,10 +174,9 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m)

174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap

175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

176

177−-- TODO remove this?

178−replaceStart :: (DomBuilder t m, MonadIO m) => m Text

177+replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text

179−replaceStart = do

178+replaceStart env = do

180− str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')

179+ str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k))

181 let key = "-" <> T.pack str

180 let key = "-" <> T.pack str

182 _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }

181 _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }

183 pure key

182 pure key

@@ -287,7 +286,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

287 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

286 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

288 StaticDomBuilderT $ do

287 StaticDomBuilderT $ do

289 let shouldEscape = elementTag `Set.notMember` noEscapeElements

288 let shouldEscape = elementTag `Set.notMember` noEscapeElements

289+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey

290− (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing

290+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey

291 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

292 selectValue <- asks _staticDomBuilderEnv_selectValue

293 let addSelectedAttr attrs sel = case Map.lookup "value" attrs of

@@ -341,7 +341,9 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

341 selectElement cfg child = do

342 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)

343 (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do

344+ (a, innerHtml) <- StaticDomBuilderT $ do

345+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey

344− (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)

346+ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey

345 StaticDomBuilderT $ lift $ modify $ (:) innerHtml

347 StaticDomBuilderT $ lift $ modify $ (:) innerHtml

346 return a

348 return a

347 let wrapped = SelectElement

349 let wrapped = SelectElement

@@ -363,7 +365,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)

363renderStatic w = do

365renderStatic w = do

364 runDomHost $ do

366 runDomHost $ do

365 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

367 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

368+ nextRunWithReplaceKey <- newRef 0

366− let env0 = StaticDomBuilderEnv True Nothing

369+ let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey

367 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

370 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

368 mPostBuildTrigger <- readRef postBuildTriggerRef

371 mPostBuildTrigger <- readRef postBuildTriggerRef

369 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

372 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs−7

@@ -138,7 +138,6 @@ dynComment t = do

138display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

139display = dynText . fmap (T.pack . show)

140

141−{-# DEPRECATED button "Use 'elAttr'' in combination with 'domEvent' instead" #-}

142button :: DomBuilder t m => Text -> m (Event t ())

141button :: DomBuilder t m => Text -> m (Event t ())

143button t = do

142button t = do

144 (e, _) <- element "button" def $ text t

143 (e, _) <- element "button" def $ text t

@@ -272,25 +271,21 @@ dynamicAttributesToModifyAttributesWithInitial attrs0 d = do

272 return $ if Map.null p then Nothing else Just p

271 return $ if Map.null p then Nothing else Just p

273 return modificationsNeeded

272 return modificationsNeeded

274

273

275−{-# DEPRECATED Link "Will be removed when 'linkClass' and 'link' are removed. Follow those functions' deprecation instructions." #-}

276newtype Link t

274newtype Link t

277 = Link { _link_clicked :: Event t ()

275 = Link { _link_clicked :: Event t ()

278 }

276 }

279

277

280−{-# DEPRECATED linkClass "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-}

281linkClass :: DomBuilder t m => Text -> Text -> m (Link t)

278linkClass :: DomBuilder t m => Text -> Text -> m (Link t)

282linkClass s c = do

279linkClass s c = do

283 (l,_) <- elAttr' "a" ("class" =: c) $ text s

280 (l,_) <- elAttr' "a" ("class" =: c) $ text s

284 return $ Link $ domEvent Click l

281 return $ Link $ domEvent Click l

285

282

286−{-# DEPRECATED link "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-}

287link :: DomBuilder t m => Text -> m (Link t)

283link :: DomBuilder t m => Text -> m (Link t)

288link s = linkClass s ""

284link s = linkClass s ""

289

285

290divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a

286divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a

291divClass = elClass "div"

287divClass = elClass "div"

292

288

293−{-# DEPRECATED dtdd "Use an application specific widget generating function" #-}

294dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a

289dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a

295dtdd h w = do

290dtdd h w = do

296 el "dt" $ text h

291 el "dt" $ text h

@@ -301,7 +296,6 @@ blank = return ()

301

296

302-- TODO: Move to an example project.

297-- TODO: Move to an example project.

303-- | A widget to display a table with static columns and dynamic rows.

298-- | A widget to display a table with static columns and dynamic rows.

304−{-# DEPRECATED tableDynAttr "Use an application specific widget generating function" #-}

305tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)

299tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)

306 => Text -- ^ Class applied to <table> element

300 => Text -- ^ Class applied to <table> element

307 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

301 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

@@ -321,7 +315,6 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo

321-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.

315-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.

322-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays

316-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays

323-- the corresponding child and hides all others.

317-- the corresponding child and hides all others.

324−{-# DEPRECATED tabDisplay "Use an application specific widget generating function" #-}

325tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)

318tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)

326 => Text -- ^ Class applied to <ul> element

319 => Text -- ^ Class applied to <ul> element

327 -> Text -- ^ Class applied to currently active <li> element

320 -> Text -- ^ Class applied to currently active <li> element

reflex-dom-core/test/hydration.hs+84−26

@@ -1,13 +1,9 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE StandaloneDeriving #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE ConstraintKinds #-}

7−{-# LANGUAGE CPP #-}

8{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

@@ -15,13 +11,18 @@

15{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE RecursiveDo #-}

12{-# LANGUAGE RecursiveDo #-}

17{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE StandaloneDeriving #-}

18{-# LANGUAGE TemplateHaskell #-}

15{-# LANGUAGE TemplateHaskell #-}

19{-# LANGUAGE TupleSections #-}

16{-# LANGUAGE TupleSections #-}

20{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeApplications #-}

21{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

19+{-# LANGUAGE UndecidableInstances #-}

20+

21+{-# OPTIONS_GHC -fno-warn-orphans #-}

23import Prelude hiding (fail)

24import Control.Concurrent

25+import qualified Control.Concurrent.Async as Async

25import Control.Lens.Operators

26import Control.Lens.Operators

26import Control.Monad hiding (fail)

27import Control.Monad hiding (fail)

27import Control.Monad.Catch

28import Control.Monad.Catch

@@ -32,7 +33,7 @@ import Control.Monad.Ref

32import Data.Constraint.Extras

33import Data.Constraint.Extras

33import Data.Constraint.Extras.TH

34import Data.Constraint.Extras.TH

34import Data.Dependent.Map (DMap)

35import Data.Dependent.Map (DMap)

35−import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))

36+import Data.Dependent.Sum (DSum(..), (==>))

36import Data.Functor.Identity

37import Data.Functor.Identity

37import Data.Functor.Misc

38import Data.Functor.Misc

38import Data.GADT.Compare.TH

39import Data.GADT.Compare.TH

@@ -63,7 +64,6 @@ import Test.Hspec (xit)

63import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)

64import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)

64import qualified Test.Hspec.WebDriver as WD

65import qualified Test.Hspec.WebDriver as WD

65import Test.WebDriver (WD(..))

66import Test.WebDriver (WD(..))

66−import Test.WebDriver.Exceptions (ServerError(..))

68import qualified Data.ByteString.Lazy as LBS

69import qualified Data.Dependent.Map as DMap

@@ -79,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD

79import Test.Util.ChromeFlags

80import Test.Util.UnshareNetwork

82+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167

83+deriving instance MonadMask WD

84+

82chromium :: FilePath

85chromium :: FilePath

83chromium = $(staticWhich "chromium")

86chromium = $(staticWhich "chromium")

@@ -924,6 +927,58 @@ tests withDebugging wdConfig caps _selenium = do

924 , el "span" . text <$> replace

927 , el "span" . text <$> replace

925 ]

928 ]

926

929

930+ let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)

931+ it "removes bracketing comments" $ runWD $ do

932+ replaceChan :: Chan () <- liftIO newChan

933+ let

934+ preSwitchover = checkInnerHtml "div" "before|inner1|after"

935+ check () = do

936+ liftIO $ writeChan replaceChan () -- trigger creation of p tag

937+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created

938+ checkInnerHtml "div" "before|<p>inner2</p>|after"

939+ testWidget' preSwitchover check $ do

940+ replace <- triggerEventWithChan replaceChan

941+ el "div" $ do

942+ text "before|"

943+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace

944+ text "|after"

945+ it "ignores extra ending bracketing comment" $ runWD $ do

946+ replaceChan :: Chan () <- liftIO newChan

947+ let

948+ preSwitchover = checkInnerHtml "div" "before|inner1|after"

949+ check () = do

950+ liftIO $ writeChan replaceChan () -- trigger creation of p tag

951+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created

952+ checkInnerHtml "div" "before|inner2|after"

953+ testWidget' preSwitchover check $ do

954+ replace <- triggerEventWithChan replaceChan

955+ el "div" $ do

956+ text "before|"

957+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace

958+ text "|after"

959+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test

960+ it "ignores missing ending bracketing comments" $ runWD $ do

961+ replaceChan :: Chan () <- liftIO newChan

962+ let

963+ preSwitchover = do

964+ checkInnerHtml "div" "before|inner1|after"

965+ divEl <- findElemWithRetry (WD.ByTag "div")

966+ let wrongHtml = "inner1"

967+ actualHtml :: String <- WD.executeJS

968+ [WD.JSArg divEl, WD.JSArg wrongHtml]

969+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"

970+ actualHtml `shouldBe` wrongHtml

971+ check () = do

972+ liftIO $ writeChan replaceChan () -- trigger creation of p tag

973+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created

974+ checkInnerHtml "div" "before|<p>inner2</p>|after"

975+ testWidget' preSwitchover check $ do

976+ replace <- triggerEventWithChan replaceChan

977+ el "div" $ do

978+ text "before|"

979+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace

980+ text "|after"

981+

927 describe "traverseDMapWithKeyWithAdjust" $ session' $ do

982 describe "traverseDMapWithKeyWithAdjust" $ session' $ do

928 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)

983 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)

929 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do

984 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do

@@ -1315,8 +1370,8 @@ withRetry a = wait 300

1315 where wait :: Int -> WD a

1370 where wait :: Int -> WD a

1316 wait 0 = a

1371 wait 0 = a

1317 wait n = try a >>= \case

1372 wait n = try a >>= \case

1318− Left (_ :: SomeException) -> do

1373+ Left (e :: SomeException) -> do

1319− liftIO $ threadDelay 100000

1374+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000

1320 wait $ n - 1

1375 wait $ n - 1

1321 Right v -> return v

1376 Right v -> return v

1322

1377

@@ -1398,23 +1453,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do

1398 ]

1453 ]

1399 -- hSilence to get rid of ConnectionClosed logs

1454 -- hSilence to get rid of ConnectionClosed logs

1400 silenceIfDebug = if withDebugging then id else hSilence [stderr]

1455 silenceIfDebug = if withDebugging then id else hSilence [stderr]

1401− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application

1456+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application

1402− jsaddleTid <- liftIO jsaddleWarp

1457+ withAsync' jsaddleWarp $ do

1403− putStrLnDebug "taking waitJSaddle"

1458+ putStrLnDebug "taking waitJSaddle"

1404− liftIO $ takeMVar waitJSaddle

1459+ liftIO $ takeMVar waitJSaddle

1405− putStrLnDebug "opening page"

1460+ putStrLnDebug "opening page"

1406− WD.openPage $ "http://localhost:" <> show jsaddlePort

1461+ WD.openPage $ "http://localhost:" <> show jsaddlePort

1407− putStrLnDebug "running beforeJS"

1462+ putStrLnDebug "running beforeJS"

1408− a <- beforeJS

1463+ a <- beforeJS

1409− putStrLnDebug "putting waitBeforeJS"

1464+ putStrLnDebug "putting waitBeforeJS"

1410− liftIO $ putMVar waitBeforeJS ()

1465+ liftIO $ putMVar waitBeforeJS ()

1411− putStrLnDebug "taking waitUntilSwitchover"

1466+ putStrLnDebug "taking waitUntilSwitchover"

1412− liftIO $ takeMVar waitUntilSwitchover

1467+ liftIO $ takeMVar waitUntilSwitchover

1413− putStrLnDebug "running afterSwitchover"

1468+ putStrLnDebug "running afterSwitchover"

1414− b <- afterSwitchover a

1469+ afterSwitchover a

1415− putStrLnDebug "killing jsaddle thread"

1470+

1416− liftIO $ killThread jsaddleTid

1471+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b

1417− return b

1472+withAsync' f g = bracket

1473+ (liftIO $ Async.async f)

1474+ (liftIO . Async.uninterruptibleCancel)

1475+ (const g)

1418

1476

1419data Key2 a where

1477data Key2 a where

1420 Key2_Int :: Int -> Key2 Int

1478 Key2_Int :: Int -> Key2 Int