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

git.iko.soy/reflex-dom

on develop help sign in

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

7f153c3Ryan Trinkle9 years ago

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

compare with develop

unifiedsplit

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

144test-suite gc

145 build-depends: base

146 , reflex-dom-core

147+ , jsaddle

147 , jsaddle-warp

148 , jsaddle-warp

148 , process

149 , process

149 , temporary

150 , temporary

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

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

208 -> ImmediateDomBuilderEnv t

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

210 -> m a

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

211+runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = do

212+ handlersMVar <- liftIO $ newMVar []

213+ flip runTriggerEventT eventChan $ do

212− win <- DOM.currentWindowUnchecked

214+ win <- DOM.currentWindowUnchecked

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

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

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

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

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

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

216− return x

218+ return x

217 where

219 where

218− runInAnimationFrame win f x = do

220+ runInAnimationFrame handlersMVar win f x = do

221+ handlers <- liftIO $ takeMVar handlersMVar

222+ when (null handlers) $ do

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

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

220− v <- synchronously x

221− _ <- liftIO $ f v

222− freeRequestAnimationFrameCallback cb

224+ freeRequestAnimationFrameCallback cb

225+ handlersToRun <- liftIO $ takeMVar handlersMVar

226+ liftIO $ putMVar handlersMVar []

227+ sequence_ (reverse handlersToRun)

223− _ <- Window.requestAnimationFrame win cb

228+ void $ Window.requestAnimationFrame win cb

224− return ()

229+ liftIO $ putMVar handlersMVar ((do

230+ v <- synchronously x

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

225

232

226class Monad m => HasDocument m where

233class Monad m => HasDocument m where

227 askDocument :: m Document

234 askDocument :: m Document

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

471 inputElement cfg = do

478 inputElement cfg = do

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

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

473 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

480 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

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

481+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue

475− v0 <- Input.getValueUnchecked domInputElement

482+ v0 <- Input.getValue domInputElement

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

483+ let getMyValue = Input.getValue domInputElement

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

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

478 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

485 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

479 Nothing -> return never

486 Nothing -> return never

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

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

481− Input.setValue domInputElement $ Just v'

488+ Input.setValue domInputElement v'

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

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

483 v <- holdDyn v0 $ leftmost

490 v <- holdDyn v0 $ leftmost

484 [ valueChangedBySetValue

491 [ valueChangedBySetValue

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

523 textAreaElement cfg = do --TODO

530 textAreaElement cfg = do --TODO

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

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

525 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

532 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

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

533+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue

527− v0 <- TextArea.getValueUnchecked domTextAreaElement

534+ v0 <- TextArea.getValue domTextAreaElement

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

535+ let getMyValue = TextArea.getValue domTextAreaElement

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

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

530 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

537 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

531 Nothing -> return never

538 Nothing -> return never

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

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

533− TextArea.setValue domTextAreaElement $ Just v'

540+ TextArea.setValue domTextAreaElement v'

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

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

535 v <- holdDyn v0 $ leftmost

542 v <- holdDyn v0 $ leftmost

536 [ valueChangedBySetValue

543 [ valueChangedBySetValue

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

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

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

75 doc <- currentDocumentUnchecked

76 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

78 body <- getBodyUnchecked doc

79 attachWidget body jsSing w

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

114

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

116replaceElementContents e df = do

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

117+ setInnerHTML e ("" :: String)

118 _ <- appendChild e df

119 return ()

120

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

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

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

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

276 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]

278 return e

279

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

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

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

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecursiveDo #-}

3+{-# LANGUAGE BangPatterns #-}

3import Control.Concurrent

4import Control.Concurrent

4import Control.Monad

5import Control.Monad

5import Control.Monad.IO.Class

6import Control.Monad.IO.Class

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

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

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

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

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

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

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

19−minBytesAllowed, maxBytesAllowed :: Int64

20+minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64

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

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

22main :: IO ()

33main :: IO ()

23main = do

34main = do

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

28 interruptProcessGroupOf browserProcess

39 interruptProcessGroupOf browserProcess

29 throwTo mainThread result

40 throwTo mainThread result

30 run 3911 $ do

41 run 3911 $ do

42+ -- enableLogging True

31 liftIO $ putStrLn "Running..."

43 liftIO $ putStrLn "Running..."

32 mainWidget $ do

44 mainWidget $ do

33 let w = do

45 let w = do

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

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

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

37 return ()

49 return ()

38 postBuild <- getPostBuild

50 postBuild <- getPostBuild

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

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

40 then do performMajorGC

52 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

42 gcStats <- getGCStats

54 gcStats <- getGCStats

43 print $ currentBytesUsed gcStats

55 print $ currentBytesUsed gcStats

44 when (currentBytesUsed gcStats < minBytesAllowed) $ do

56 when (currentBytesUsed gcStats < minBytesAllowed) $ do

45 putStrLn "FAILED: currentBytesUsed < minBytesAllowed"

57 putStrLn "FAILED: currentBytesUsed < minBytesAllowed"

46 finishTest $ ExitFailure 2

58 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

48 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"

62 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"

49 finishTest $ ExitFailure 1

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

51 else do putStrLn "SUCCEEDED"

68 else do putStrLn "SUCCEEDED"

52 finishTest ExitSuccess

69 finishTest ExitSuccess

53 return Nothing

70 return Nothing

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

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

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

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

56 , fmapMaybe id redraw

73 , fmapMaybe id redraw

57 ]

74 ]

58 _ <- widgetHold w $ w <$ redraw

75 _ <- widgetHold w $ w <$ redraw