7f153c3 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge remote-tracking branch 'origin/ghcjs-dom-0.9' into develop

commit7f153c3d3cc65bdfa7f57f116d155e91fac251d1 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 25 Jun 2017, 14:41 (9 years ago) parenta20e829 3bd6bf8

5 files changed+56−31

compare with develop

unifiedsplit

reflex-dom-core/reflex-dom-core.cabal+1 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+28−21 reflex-dom-core/src/Reflex/Dom/Main.hs+2−2 reflex-dom-core/src/Reflex/Dom/Old.hs+1−1 reflex-dom-core/test/gc.hs+24−7

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

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

144144test-suite gc

145145 build-depends: base

146146 , reflex-dom-core

147+ , jsaddle

147148 , jsaddle-warp

148149 , process

149150 , temporary

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+28−21

@@ -208,20 +208,27 @@ runImmediateDomBuilderT

208208 -> ImmediateDomBuilderEnv t

209209 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

210210 -> m a

211−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = flip runTriggerEventT eventChan $ do

212− win <- DOM.currentWindowUnchecked

213− rec (x, req) <- runRequesterT (runReaderT a env) rsp

214− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame win f $

215− DMap.traverseWithKey (\_ r -> Identity <$> r) rm

216− return x

211+runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = do

212+ handlersMVar <- liftIO $ newMVar []

213+ flip runTriggerEventT eventChan $ do

214+ win <- DOM.currentWindowUnchecked

215+ rec (x, req) <- runRequesterT (runReaderT a env) rsp

216+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame handlersMVar win f $

217+ DMap.traverseWithKey (\_ r -> Identity <$> r) rm

218+ return x

217219 where

218− runInAnimationFrame win f x = do

219− rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do

220− v <- synchronously x

221− _ <- liftIO $ f v

222− freeRequestAnimationFrameCallback cb

223− _ <- Window.requestAnimationFrame win cb

224− return ()

220+ runInAnimationFrame handlersMVar win f x = do

221+ handlers <- liftIO $ takeMVar handlersMVar

222+ when (null handlers) $ do

223+ rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do

224+ freeRequestAnimationFrameCallback cb

225+ handlersToRun <- liftIO $ takeMVar handlersMVar

226+ liftIO $ putMVar handlersMVar []

227+ sequence_ (reverse handlersToRun)

228+ void $ Window.requestAnimationFrame win cb

229+ liftIO $ putMVar handlersMVar ((do

230+ v <- synchronously x

231+ void . liftIO $ f v) : handlers)

225232

226233class Monad m => HasDocument m where

227234 askDocument :: m Document

@@ -471,14 +478,14 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

471478 inputElement cfg = do

472479 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

473480 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

474− Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)

475− v0 <- Input.getValueUnchecked domInputElement

476− let getMyValue = fromMaybe "" <$> Input.getValue domInputElement

481+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue

482+ v0 <- Input.getValue domInputElement

483+ let getMyValue = Input.getValue domInputElement

477484 valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

478485 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

479486 Nothing -> return never

480487 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

481− Input.setValue domInputElement $ Just v'

488+ Input.setValue domInputElement v'

482489 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

483490 v <- holdDyn v0 $ leftmost

484491 [ valueChangedBySetValue

@@ -523,14 +530,14 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

523530 textAreaElement cfg = do --TODO

524531 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

525532 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

526− TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)

527− v0 <- TextArea.getValueUnchecked domTextAreaElement

528− let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement

533+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue

534+ v0 <- TextArea.getValue domTextAreaElement

535+ let getMyValue = TextArea.getValue domTextAreaElement

529536 valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

530537 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

531538 Nothing -> return never

532539 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

533− TextArea.setValue domTextAreaElement $ Just v'

540+ TextArea.setValue domTextAreaElement v'

534541 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

535542 v <- holdDyn v0 $ leftmost

536543 [ valueChangedBySetValue

reflex-dom-core/src/Reflex/Dom/Main.hs+2−2

@@ -74,7 +74,7 @@ mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> JSM ()

7474mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do

7575 doc <- currentDocumentUnchecked

7676 headElement <- getHeadUnchecked doc

77− setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

77+ setInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

7878 body <- getBodyUnchecked doc

7979 attachWidget body jsSing w

8080

@@ -114,7 +114,7 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do

114114

115115replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> JSM ()

116116replaceElementContents e df = do

117− setInnerHTML e $ Just ("" :: String)

117+ setInnerHTML e ("" :: String)

118118 _ <- appendChild e df

119119 return ()

120120

reflex-dom-core/src/Reflex/Dom/Old.hs+1−1

@@ -274,7 +274,7 @@ elDynHtmlAttr' elementTag attrs html = do

274274 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

275275 (e, _) <- element elementTag cfg $ return ()

276276 postBuild <- getPostBuild

277− performEvent_ $ liftJSM . Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]

277+ performEvent_ $ liftJSM . Element.setInnerHTML (_element_raw e) <$> leftmost [updated html, tag (current html) postBuild]

278278 return e

279279

280280elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

reflex-dom-core/test/gc.hs+24−7

@@ -1,5 +1,6 @@

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE RecursiveDo #-}

3+{-# LANGUAGE BangPatterns #-}

34import Control.Concurrent

45import Control.Monad

56import Control.Monad.IO.Class

@@ -16,8 +17,18 @@ import System.Process

1617-- 363712. Going over the maximum means the test has actually failed - we

1718-- probably have a memory leak; going under the minimum doesn't indicate a

1819-- memory leak, but may mean the test needs to be updated.

19−minBytesAllowed, maxBytesAllowed :: Int64

20−(minBytesAllowed, maxBytesAllowed) = (200000, 450000)

20+minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64

21+(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 490000)

22+

23+-- Some times the memory usage might flair up and then then return to normal

24+-- this probably indicates an issue, but if you are trying to fix a slow consistent

25+-- leak it can confuse the results by making the tests fail when the slow leak is

26+-- fixed.

27+-- Set this limit to say how many failures (currentBytesUsed > maxBytesAllowed)

28+-- want to ignore. If the memory usage goes back under resetThreshold

29+-- the failure count is reset to 0.

30+failureLimit :: Int

31+failureLimit = 0

2132

2233main :: IO ()

2334main = do

@@ -28,6 +39,7 @@ main = do

2839 interruptProcessGroupOf browserProcess

2940 throwTo mainThread result

3041 run 3911 $ do

42+ -- enableLogging True

3143 liftIO $ putStrLn "Running..."

3244 mainWidget $ do

3345 let w = do

@@ -36,23 +48,28 @@ main = do

3648 d <- holdDyn mempty $ mempty <$ domEvent Click e

3749 return ()

3850 postBuild <- getPostBuild

39− let f n = liftIO $ if n < 3000

51+ let f (!failures, !n) = liftIO $ if n < 3000

4052 then do performMajorGC

41− threadDelay 1000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined

53+ threadDelay 5000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined

4254 gcStats <- getGCStats

4355 print $ currentBytesUsed gcStats

4456 when (currentBytesUsed gcStats < minBytesAllowed) $ do

4557 putStrLn "FAILED: currentBytesUsed < minBytesAllowed"

4658 finishTest $ ExitFailure 2

47− when (currentBytesUsed gcStats > maxBytesAllowed) $ do

59+ let overMax = currentBytesUsed gcStats > maxBytesAllowed

60+ underReset = currentBytesUsed gcStats < resetThreshold

61+ when (overMax && failures >= failureLimit) $ do

4862 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"

4963 finishTest $ ExitFailure 1

50− return $ Just $ succ n

64+ return $ Just (

65+ if overMax

66+ then succ failures

67+ else (if underReset then 0 else failures), succ n)

5168 else do putStrLn "SUCCEEDED"

5269 finishTest ExitSuccess

5370 return Nothing

5471 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost

55− [ (0 :: Int) <$ postBuild

72+ [ ((0 :: Int), (0 :: Int)) <$ postBuild

5673 , fmapMaybe id redraw

5774 ]

5875 _ <- widgetHold w $ w <$ redraw