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

git.iko.soy/reflex-dom

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

commit886a123baa5f3d52b9672ee9f7fa17d81cb71100 authorElliot Cameron <3noch@users.noreply.github.com> dateMon 9 Mar 2020, 12:19 (7 years ago) parent97dd3bc f11eba4

6 files changed+139−64

compare with develop

unifiedsplit

reflex-dom-core/ChangeLog.md+13 reflex-dom-core/reflex-dom-core.cabal+1 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+29−22 reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+12−9 reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs−7 reflex-dom-core/test/hydration.hs+84−26

reflex-dom-core/ChangeLog.md+13

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

77* 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+

922## 0.5.3

1023

1124* 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

166166test-suite hydration

167167 build-depends: base

168168 , aeson

169+ , async

169170 , bytestring

170171 , chrome-test-utils

171172 , constraints

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

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

12711271skipToAndReplaceComment

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

12731273 => Text

1274− -> IORef Text

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

1274+ -> IORef (Maybe Text)

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

12761276skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

12771277 HydrationMode_Immediate -> do

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

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

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

12811281 append $ toNode t

12821282 textNodeRef <- liftIO $ newIORef t

1283− keyRef <- liftIO $ newIORef ""

1283+ keyRef <- liftIO $ newIORef Nothing

12841284 pure (pure (), textNodeRef, keyRef)

12851285 HydrationMode_Hydrating -> do

12861286 doc <- askDocument

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

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

1289− let go key0 mLastNode = do

1290− parent <- askParent

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

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

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)

1295+ go (Just key0) mLastNode = do

1296+ parent <- askParent

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

1298+ Nothing -> go Nothing Nothing

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

12931300 Just comment -> do

1294− commentText <- Node.getTextContentUnchecked comment

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

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

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.

12961303 Just key -> do

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

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

12991306 Node.replaceChild_ parent tn comment

1300− pure (tn, key)

1307+ pure (tn, Just key)

13011308 Nothing -> do

1302− go key0 (Just node)

1309+ go (Just key0) (Just node)

13031310 Nothing -> do

1304− go key0 (Just node)

1305− switchComment = do

1306− key0 <- liftIO $ readIORef key0Ref

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

1308− setPreviousNode $ Just $ toNode tn

1309− liftIO $ do

1310− writeIORef textNodeRef tn

1311− writeIORef keyRef key

1311+ go (Just key0) (Just node)

1312+ switchComment = do

1313+ key0 <- liftIO $ readIORef key0Ref

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

1315+ setPreviousNode $ Just $ toNode tn

1316+ liftIO $ do

1317+ writeIORef textNodeRef tn

1318+ writeIORef keyRef key

13121319 pure (switchComment, textNodeRef, keyRef)

13131320

13141321{-# 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)

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

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))

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

13171324

13181325{-# 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)

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

13211328

13221329instance 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

5555import Reflex.PostBuild.Base

5656import Reflex.PostBuild.Class

5757import Reflex.TriggerEvent.Class

58−import System.Random (randomRIO)

5958

6059data StaticDomBuilderEnv t = StaticDomBuilderEnv

6160 { _staticDomBuilderEnv_shouldEscape :: Bool

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

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

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

6665 -- 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

6767 }

6868

6969newtype StaticDomBuilderT t m a = StaticDomBuilderT

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

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

165165 runWithReplace a0 a' = do

166166 e <- StaticDomBuilderT ask

167− key <- replaceStart

167+ key <- replaceStart e

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

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

170170 StaticDomBuilderT $ modify $ (:) $ join o

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

174174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap

175175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

176176

177−-- TODO remove this?

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

179−replaceStart = do

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

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

178+replaceStart env = do

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

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

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

183182 pure key

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

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

288287 StaticDomBuilderT $ do

289288 let shouldEscape = elementTag `Set.notMember` noEscapeElements

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

289+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey

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

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

292292 selectValue <- asks _staticDomBuilderEnv_selectValue

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

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

341341 selectElement cfg child = do

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

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

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

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

345+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey

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

345347 StaticDomBuilderT $ lift $ modify $ (:) innerHtml

346348 return a

347349 let wrapped = SelectElement

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

363365renderStatic w = do

364366 runDomHost $ do

365367 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

366− let env0 = StaticDomBuilderEnv True Nothing

368+ nextRunWithReplaceKey <- newRef 0

369+ let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey

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

368371 mPostBuildTrigger <- readRef postBuildTriggerRef

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

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

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

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

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

140140

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

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

143142button t = do

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

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

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

273272 return modificationsNeeded

274273

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

276274newtype Link t

277275 = Link { _link_clicked :: Event t ()

278276 }

279277

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

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

282279linkClass s c = do

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

284281 return $ Link $ domEvent Click l

285282

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

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

288284link s = linkClass s ""

289285

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

291287divClass = elClass "div"

292288

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

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

295290dtdd h w = do

296291 el "dt" $ text h

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

301296

302297-- TODO: Move to an example project.

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

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

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

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

307301 -> [(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

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

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

323317-- the corresponding child and hides all others.

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

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

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

327320 -> 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 #-}

21{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE StandaloneDeriving #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE UndecidableInstances #-}

62{-# LANGUAGE ConstraintKinds #-}

7−{-# LANGUAGE CPP #-}

83{-# LANGUAGE FlexibleContexts #-}

94{-# LANGUAGE FlexibleInstances #-}

105{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

117{-# LANGUAGE LambdaCase #-}

128{-# LANGUAGE MultiParamTypeClasses #-}

139{-# LANGUAGE OverloadedStrings #-}

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

1511{-# LANGUAGE RankNTypes #-}

1612{-# LANGUAGE RecursiveDo #-}

1713{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE StandaloneDeriving #-}

1815{-# LANGUAGE TemplateHaskell #-}

1916{-# LANGUAGE TupleSections #-}

2017{-# LANGUAGE TypeApplications #-}

2118{-# LANGUAGE TypeFamilies #-}

19+{-# LANGUAGE UndecidableInstances #-}

20+

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

2222

2323import Prelude hiding (fail)

2424import Control.Concurrent

25+import qualified Control.Concurrent.Async as Async

2526import Control.Lens.Operators

2627import Control.Monad hiding (fail)

2728import Control.Monad.Catch

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

3233import Data.Constraint.Extras

3334import Data.Constraint.Extras.TH

3435import Data.Dependent.Map (DMap)

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

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

3637import Data.Functor.Identity

3738import Data.Functor.Misc

3839import Data.GADT.Compare.TH

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

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

6465import qualified Test.Hspec.WebDriver as WD

6566import Test.WebDriver (WD(..))

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

6767

6868import qualified Data.ByteString.Lazy as LBS

6969import qualified Data.Dependent.Map as DMap

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

7979import Test.Util.ChromeFlags

8080import Test.Util.UnshareNetwork

8181

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

83+deriving instance MonadMask WD

84+

8285chromium :: FilePath

8386chromium = $(staticWhich "chromium")

8487

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

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

925928 ]

926929

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+

927982 describe "traverseDMapWithKeyWithAdjust" $ session' $ do

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

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

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

13151370 where wait :: Int -> WD a

13161371 wait 0 = a

13171372 wait n = try a >>= \case

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

1319− liftIO $ threadDelay 100000

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

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

13201375 wait $ n - 1

13211376 Right v -> return v

13221377

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

13981453 ]

13991454 -- hSilence to get rid of ConnectionClosed logs

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

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

1402− jsaddleTid <- liftIO jsaddleWarp

1403− putStrLnDebug "taking waitJSaddle"

1404− liftIO $ takeMVar waitJSaddle

1405− putStrLnDebug "opening page"

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

1407− putStrLnDebug "running beforeJS"

1408− a <- beforeJS

1409− putStrLnDebug "putting waitBeforeJS"

1410− liftIO $ putMVar waitBeforeJS ()

1411− putStrLnDebug "taking waitUntilSwitchover"

1412− liftIO $ takeMVar waitUntilSwitchover

1413− putStrLnDebug "running afterSwitchover"

1414− b <- afterSwitchover a

1415− putStrLnDebug "killing jsaddle thread"

1416− liftIO $ killThread jsaddleTid

1417− return b

1456+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application

1457+ withAsync' jsaddleWarp $ do

1458+ putStrLnDebug "taking waitJSaddle"

1459+ liftIO $ takeMVar waitJSaddle

1460+ putStrLnDebug "opening page"

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

1462+ putStrLnDebug "running beforeJS"

1463+ a <- beforeJS

1464+ putStrLnDebug "putting waitBeforeJS"

1465+ liftIO $ putMVar waitBeforeJS ()

1466+ putStrLnDebug "taking waitUntilSwitchover"

1467+ liftIO $ takeMVar waitUntilSwitchover

1468+ putStrLnDebug "running afterSwitchover"

1469+ afterSwitchover a

1470+

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

1472+withAsync' f g = bracket

1473+ (liftIO $ Async.async f)

1474+ (liftIO . Async.uninterruptibleCancel)

1475+ (const g)

14181476

14191477data Key2 a where

14201478 Key2_Int :: Int -> Key2 Int