1b2212c · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'develop' into cn-return-correct-result-for-wheel

1b2212cElliot Cameron7 years ago

reflex-dom-core/ChangeLog.md+2

compare with develop

unifiedsplit

@@ -17,6 +17,8 @@

17 * `tabDisplay`

18 * `tableDynAttr`

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

21+

20## 0.5.3

22## 0.5.3

22* 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+30−24

@@ -319,8 +319,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati

319addHydrationStepWithSetup setup f = getHydrationMode >>= \case

320 HydrationMode_Immediate -> pure ()

321 HydrationMode_Hydrating -> do

322− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

322+ s <- lift setup

323− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover

324 addHydrationStep (f s)

323 addHydrationStep (f s)

325

324

326-- | Add a hydration step

325-- | Add a hydration step

@@ -1273,8 +1272,8 @@ hydrateComment doc t mSetContents = do

1273skipToAndReplaceComment

1272skipToAndReplaceComment

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

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

1275 => Text

1274 => Text

1276− -> IORef Text

1275+ -> IORef (Maybe Text)

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

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

1278skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1277skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1279 HydrationMode_Immediate -> do

1278 HydrationMode_Immediate -> do

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

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

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

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

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

1283 append $ toNode t

1282 append $ toNode t

1284 textNodeRef <- liftIO $ newIORef t

1283 textNodeRef <- liftIO $ newIORef t

1285− keyRef <- liftIO $ newIORef ""

1284+ keyRef <- liftIO $ newIORef Nothing

1286 pure (pure (), textNodeRef, keyRef)

1285 pure (pure (), textNodeRef, keyRef)

1287 HydrationMode_Hydrating -> do

1286 HydrationMode_Hydrating -> do

1288 doc <- askDocument

1287 doc <- askDocument

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

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

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

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

1290+ let

1291+ go Nothing _ = do

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

1293+ insertAfterPreviousNode tn

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

1295+ pure (tn, Nothing)

1291− let go key0 mLastNode = do

1296+ go (Just key0) mLastNode = do

1292− parent <- askParent

1297+ parent <- askParent

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

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

1299+ Nothing -> go Nothing Nothing

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

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

1295 Just comment -> do

1301 Just comment -> do

1296− commentText <- Node.getTextContentUnchecked comment

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

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

1303+ 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.

1298 Just key -> do

1304 Just key -> do

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

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

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

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

1301 Node.replaceChild_ parent tn comment

1307 Node.replaceChild_ parent tn comment

1302− pure (tn, key)

1308+ pure (tn, Just key)

1303 Nothing -> do

1309 Nothing -> do

1304− go key0 (Just node)

1310+ go (Just key0) (Just node)

1305 Nothing -> do

1311 Nothing -> do

1306− go key0 (Just node)

1312+ go (Just key0) (Just node)

1307− switchComment = do

1313+ switchComment = do

1308− key0 <- liftIO $ readIORef key0Ref

1314+ key0 <- liftIO $ readIORef key0Ref

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

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

1310− setPreviousNode $ Just $ toNode tn

1316+ setPreviousNode $ Just $ toNode tn

1311− liftIO $ do

1317+ liftIO $ do

1312− writeIORef textNodeRef tn

1318+ writeIORef textNodeRef tn

1313− writeIORef keyRef key

1319+ writeIORef keyRef key

1314 pure (switchComment, textNodeRef, keyRef)

1320 pure (switchComment, textNodeRef, keyRef)

1315

1321

1316{-# INLINABLE skipToReplaceStart #-}

1322{-# INLINABLE skipToReplaceStart #-}

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

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

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

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

1319

1325

1320{-# INLINABLE skipToReplaceEnd #-}

1326{-# INLINABLE skipToReplaceEnd #-}

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

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

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

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

1323

1329

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

1330instance 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/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