17baefe · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

GC test fully working

17baefeRyan Trinkle10 years ago

default.nix+4−2

compare with develop

unifiedsplit

@@ -1,4 +1,6 @@

1−haskellPackages: {

1+haskellPackages: nixpkgs: {

2 reflex-dom = haskellPackages.callPackage ./reflex-dom {};

3− reflex-dom-core = haskellPackages.callPackage ./reflex-dom-core {};

3+ reflex-dom-core = haskellPackages.callPackage ./reflex-dom-core {

4+ inherit (nixpkgs) xvfb_run chromium;

5+ };

reflex-dom-core/default.nix+24−44

@@ -1,48 +1,28 @@

1−{ mkDerivation, pkgs, dependent-map, ghcjs-dom, lens

1+{ mkDerivation, ghc, aeson, base, bifunctors, bimap, blaze-builder

2−, mtl, ref-tf, reflex, text, these

2+, bytestring, containers, contravariant, data-default

3−, transformers, data-default, semigroups, blaze-builder, aeson

3+, dependent-map, dependent-sum, dependent-sum-template, directory

4−, ghc, exception-transformers

4+, exception-transformers, ghcjs-dom, hlint, jsaddle, keycode, lens

5−, dependent-sum-template, bifunctors, bimap

5+, monad-control, mtl, primitive, random, ref-tf, reflex, semigroups

6−, raw-strings-qq, zenc, random, monad-control, keycode, hlint

6+, stdenv, stm, template-haskell, temporary, text, these, time

7−, unbounded-delays, jsaddle

7+, transformers, unbounded-delays, unix, zenc, hashable, xvfb_run

8+, chromium, process, jsaddle-warp

8}:

9}:

9−

10mkDerivation {

11 pname = "reflex-dom-core";

12− version = "0.3";

12+ version = "0.4";

13− src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

13+ src = ./.;

14− buildDepends = [

14+ libraryHaskellDepends = [

15− aeson

15+ aeson base bifunctors bimap blaze-builder bytestring containers

16− bifunctors

17− bimap

18− blaze-builder

19− data-default

20− dependent-map

16+ contravariant data-default dependent-map dependent-sum

21− dependent-sum-template

22− exception-transformers

17+ dependent-sum-template directory exception-transformers ghcjs-dom

23− ghcjs-dom

18+ jsaddle keycode lens monad-control mtl primitive random ref-tf

24− jsaddle

19+ reflex semigroups stm template-haskell text these time transformers

25− keycode

26− lens

27− monad-control

28− mtl

29− random

30− ref-tf

31− reflex

32− semigroups

33− text

34− these

35− transformers

36− unbounded-delays

20+ unbounded-delays unix zenc

37− zenc

38− ] ++ (if ghc.isGhcjs or false then [] else [

21+ ] ++ (if ghc.isGhcjs or false then [

39− raw-strings-qq

22+ hashable

40− ]);

23+ ] else []);

41− testDepends = if ghc.isGhcjs or false then [] else [

24+ testHaskellDepends = [ base hlint temporary jsaddle-warp process ];

42− hlint

25+ testSystemDepends = [ xvfb_run chromium ];

43− ];

26+ description = "Functional Reactive Web Apps with Reflex";

44− pkgconfigDepends = if ghc.isGhcjs or false then [] else [

27+ license = stdenv.lib.licenses.bsd3;

45− raw-strings-qq

46− ];

47− license = null;

48}

28}

reflex-dom-core/reflex-dom-core.cabal+17−5

@@ -123,11 +123,23 @@ library

123 build-depends:

124 dependent-sum == 0.4.*

125

126−--test-suite hlint

126+test-suite hlint

127−-- build-depends: base, hlint == 1.9.*

127+ build-depends: base, hlint == 1.9.*

128−-- hs-source-dirs: test

128+ hs-source-dirs: test

129−-- main-is: hlint.hs

129+ main-is: hlint.hs

130−-- type: exitcode-stdio-1.0

130+ type: exitcode-stdio-1.0

131+

132+test-suite gc

133+ build-depends: base

134+ , reflex-dom-core

135+ , jsaddle-warp

136+ , process

137+ , temporary

138+ hs-source-dirs: test

139+ ghc-options: -rtsopts -with-rtsopts=-T -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

140+ ghc-prof-options: -fprof-auto

141+ main-is: gc.hs

142+ type: exitcode-stdio-1.0

131

143

132source-repository head

144source-repository head

133 type: git

145 type: git

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+54−45

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

@@ -31,7 +32,6 @@ import Reflex.TriggerEvent.Base hiding (askEvents)

31import Reflex.TriggerEvent.Class

32import Reflex.TriggerEvent.Class

33import Control.Concurrent.Chan

34import Control.Concurrent.Chan

34−import Control.Exception (evaluate)

35import Control.Lens hiding (element, ix)

36import Control.Monad.Exception

37import Control.Monad.Primitive

@@ -55,6 +55,7 @@ import Data.Monoid

55import Data.Some (Some)

56import qualified Data.Some as Some

57import Data.Text (Text)

58+import qualified Data.Text as T

58import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)

59import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)

59import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

60import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

60import qualified GHCJS.DOM.Element as Element

61import qualified GHCJS.DOM.Element as Element

@@ -81,8 +82,6 @@ import GHCJS.DOM.UIEvent

81import qualified GHCJS.DOM.Window as Window

82import qualified GHCJS.DOM.Window as Window

82import Language.Javascript.JSaddle (call, eval)

83import Language.Javascript.JSaddle (call, eval)

84−import Debug.Trace hiding (traceEvent)

85−

86data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }

85data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }

88data ImmediateDomBuilderEnv t

87data ImmediateDomBuilderEnv t

@@ -146,31 +145,36 @@ textNodeInternal t = do

146{-# INLINABLE deleteBetweenInclusive #-}

145{-# INLINABLE deleteBetweenInclusive #-}

147deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

146deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

148deleteBetweenInclusive s e = liftJSM $ do

147deleteBetweenInclusive s e = liftJSM $ do

148+ f <- eval $ T.unlines

149− f <- eval ("(function(s,e){ \

149+ [ "(function(s,e){"

150− p = e.parentNode; \

150+ , " p = e.parentNode;"

151− if(p !== null) { \

151+ , " if(p !== null) {"

152− for(;;){ \

152+ , " for(;;){"

153− x = e.previousSibling; \

153+ , " x = e.previousSibling;"

154− p.removeChild(x); \

154+ , " p.removeChild(x);"

155− if(s===x) break; \

155+ , " if(s===x) break;"

156− } \

156+ , " }"

157− p.removeChild(e); \

157+ , " p.removeChild(e);"

158− }})" :: Text)

158+ , " }"

159+ , "})"

160+ ]

159 void $ call f f (s, e)

161 void $ call f f (s, e)

160

162

161-- | s and e must both be children of the same node and s must precede e;

163-- | s and e must both be children of the same node and s must precede e;

162-- all nodes between s and e will be removed, but s and e will not be removed

164-- all nodes between s and e will be removed, but s and e will not be removed

163deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

165deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

164deleteBetweenExclusive s e = liftJSM $ do

166deleteBetweenExclusive s e = liftJSM $ do

167+ f <- eval $ T.unlines

165− f <- eval ("(function(s,e){ \

168+ [ "(function(s,e){"

166− p = e.parentNode; \

169+ , " p = e.parentNode;"

167− if(p !== null) { \

170+ , " if(p !== null) {"

168− for(;;){ \

171+ , " for(;;){"

169− x = e.previousSibling; \

172+ , " x = e.previousSibling;"

170− if(s===x) break; \

173+ , " if(s===x) break;"

171− p.removeChild(x); \

174+ , " p.removeChild(x);"

172− } \

175+ , " }"

173− }})" :: Text)

176+ , " }})"

177+ ]

174 void $ call f f (s, e)

178 void $ call f f (s, e)

175

179

176-- | s and e must both be children of the same node and s must precede e;

180-- | s and e must both be children of the same node and s must precede e;

@@ -178,27 +182,31 @@ deleteBetweenExclusive s e = liftJSM $ do

178{-# INLINABLE deleteUpTo #-}

182{-# INLINABLE deleteUpTo #-}

179deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

183deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

180deleteUpTo s e = liftJSM $ do

184deleteUpTo s e = liftJSM $ do

185+ f <- eval $ T.unlines

181− f <- eval ("(function(s,e){ \

186+ [ "(function(s,e){"

182− p = e.parentNode; \

187+ , " p = e.parentNode;"

183− if(p !== null) { \

188+ , " if(p !== null) {"

184− for(;;) { \

189+ , " for(;;) {"

185− x = e.previousSibling; \

190+ , " x = e.previousSibling;"

186− p.removeChild(x); \

191+ , " p.removeChild(x);"

187− if(s===x) break; \

192+ , " if(s===x) break;"

188− } \

193+ , " }"

189− }})" :: Text)

194+ , " }})"

195+ ]

190 void $ call f f (s, e)

196 void $ call f f (s, e)

191

197

192-- | s and all nodes between s and e will be removed, but e will not be removed

198-- | s and all nodes between s and e will be removed, but e will not be removed

193{-# INLINABLE deleteUpToGivenParent #-}

199{-# INLINABLE deleteUpToGivenParent #-}

194deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

200deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

195deleteUpToGivenParent currentParent s e = liftJSM $ do

201deleteUpToGivenParent currentParent s e = liftJSM $ do

202+ f <- eval $ T.unlines

196− f <- eval ("(function(p,s,e){ \

203+ [ "(function(p,s,e){"

197− for(;;){ \

204+ , " for(;;){"

198− x = e.previousSibling; \

205+ , " x = e.previousSibling;"

199− p.removeChild(x); \

206+ , " p.removeChild(x);"

200− if(s===x) break; \

207+ , " if(s===x) break;"

201− }})" :: Text)

208+ , " }})"

209+ ]

202 void $ call f f (currentParent, s, e)

210 void $ call f f (currentParent, s, e)

203

211

204type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m)

212type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m)

@@ -225,9 +233,8 @@ wrap e cfg = do

225 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]

233 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]

226 return $ en :=> EventFilterTriggerRef triggerRef

234 return $ en :=> EventFilterTriggerRef triggerRef

227 es <- do

235 es <- do

228− let h :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))

236+ let h :: GhcjsEventHandler er

229− h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up

237+ !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up

230− _ <- liftIO $ evaluate h

231 ctx <- askJSM

238 ctx <- askJSM

232 newFanEventWithTrigger $ \(WrapArg en) t ->

239 newFanEventWithTrigger $ \(WrapArg en) t ->

233 case DMap.lookup en eventTriggerRefs of

240 case DMap.lookup en eventTriggerRefs of

@@ -237,7 +244,7 @@ wrap e cfg = do

237 writeIORef r Nothing

244 writeIORef r Nothing

238 Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

245 Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

239 evt <- DOM.event

246 evt <- DOM.event

240− mv <- lift $ h (en, GhcjsDomEvent evt)

247+ mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)

241 case mv of

248 case mv of

242 Nothing -> return ()

249 Nothing -> return ()

243 Just v -> liftIO $ do

250 Just v -> liftIO $ do

@@ -286,7 +293,7 @@ instance DomSpace GhcjsDomSpace where

286 { _ghcjsEventSpec_filters =

293 { _ghcjsEventSpec_filters =

287 let f' = Just . GhcjsEventFilter . \case

294 let f' = Just . GhcjsEventFilter . \case

288 Nothing -> \evt -> do

295 Nothing -> \evt -> do

289− mEventResult <- _ghcjsEventSpec_handler es (en, evt)

296+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)

290 return (f mEventResult, return mEventResult)

297 return (f mEventResult, return mEventResult)

291 Just (GhcjsEventFilter oldFilter) -> \evt -> do

298 Just (GhcjsEventFilter oldFilter) -> \evt -> do

292 (oldFlags, oldContinuation) <- oldFilter evt

299 (oldFlags, oldContinuation) <- oldFilter evt

@@ -304,9 +311,11 @@ data Maybe1 f a = Nothing1 | Just1 (f a)

304

311

305data GhcjsEventSpec er = GhcjsEventSpec

312data GhcjsEventSpec er = GhcjsEventSpec

306 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)

313 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)

307− , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))

314+ , _ghcjsEventSpec_handler :: GhcjsEventHandler er

308 }

315 }

309

316

317+newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }

318+

310#ifndef USE_TEMPLATE_HASKELL

319#ifndef USE_TEMPLATE_HASKELL

311phantom2 :: (Functor f, Contravariant f) => f a -> f b

320phantom2 :: (Functor f, Contravariant f) => f a -> f b

312phantom2 = phantom

321phantom2 = phantom

@@ -316,14 +325,14 @@ ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName

316ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a

325ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a

317{-# INLINE ghcjsEventSpec_filters #-}

326{-# INLINE ghcjsEventSpec_filters #-}

318ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))

327ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))

319−ghcjsEventSpec_handler f (GhcjsEventSpec _ b) = phantom2 (f b)

328+ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom2 (f b)

320{-# INLINE ghcjsEventSpec_handler #-}

329{-# INLINE ghcjsEventSpec_handler #-}

321#endif

330#endif

322

331

323instance er ~ EventResult => Default (GhcjsEventSpec er) where

332instance er ~ EventResult => Default (GhcjsEventSpec er) where

324 def = GhcjsEventSpec

333 def = GhcjsEventSpec

325 { _ghcjsEventSpec_filters = mempty

334 { _ghcjsEventSpec_filters = mempty

326− , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do

335+ , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> do

327 t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument

336 t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument

328 let e = uncheckedCastTo DOM.Element t

337 let e = uncheckedCastTo DOM.Element t

329 runReaderT (defaultDomEventHandler e en) evt

338 runReaderT (defaultDomEventHandler e en) evt

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

@@ -43,7 +43,7 @@ import GHCJS.DOM.Document

43import GHCJS.DOM.Element

44import GHCJS.DOM.Node

45import qualified GHCJS.DOM.Types as DOM

46−import GHCJS.DOM.Types (MonadJSM(..), JSM)

46+import GHCJS.DOM.Types (JSM)

48{-# INLINABLE mainWidget #-}

49mainWidget :: (forall x. Widget x ()) -> JSM ()

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

@@ -69,9 +69,9 @@ import Foreign.JavaScript.TH

69import qualified GHCJS.DOM.Element as Element

70import GHCJS.DOM.EventM (EventM)

71import GHCJS.DOM.NamedNodeMap as NNM

72−import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChildUnchecked)

72+import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChildUnchecked)

73import GHCJS.DOM.Types

74− (MonadJSM, strictEqual, liftJSM, JSM, IsElement, IsNode)

74+ (MonadJSM, liftJSM, JSM, IsElement, IsNode)

75import qualified GHCJS.DOM.Types as DOM

76import Reflex.Class

77import Reflex.Dom.Builder.Class

@@ -236,7 +236,7 @@ wrapElement eh e = do

236 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt

237 wrapRawElement e $ (def :: RawElementConfig EventResult t m)

238 { _rawElementConfig_eventSpec = def

239− { _ghcjsEventSpec_handler = h

239+ { _ghcjsEventSpec_handler = GhcjsEventHandler h

240 }

241 }

242

@@ -259,7 +259,7 @@ nodeClear n = do

259 case mfc of

260 Nothing -> return ()

261 Just fc -> do

262− removeChildUnchecked n $ Just fc

262+ _ <- removeChildUnchecked n $ Just fc

263 nodeClear n

264

265elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a

reflex-dom-core/src/Reflex/Dom/Widget/Input.hs+3−3

@@ -296,12 +296,12 @@ checkboxView dAttrs dValue = do

296 , _elementConfig_initialAttributes = Map.mapKeys (AttributeName Nothing) permanentAttrs

297 , _elementConfig_eventSpec = GhcjsEventSpec

298 { _ghcjsEventSpec_filters = filters

299− , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of

299+ , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> case en of

300 Click -> error "impossible"

301 _ -> do

302 e :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt

303− let element = uncheckedCastTo DOM.Element e

303+ let myElement = uncheckedCastTo DOM.Element e

304− mr <- runReaderT (defaultDomEventHandler element en) evt

304+ mr <- runReaderT (defaultDomEventHandler myElement en) evt

305 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r

306 }

307 }

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

@@ -246,7 +246,6 @@ newXMLHttpRequestWithError

246 -> m XMLHttpRequest

247 -- ^ The XHR request, which could for example be aborted.

248newXMLHttpRequestWithError req cb = do

249− wv <- askJSContext

250 xhr <- xmlHttpRequestNew

249 xhr <- xmlHttpRequestNew

251 ctx <- askJSM

250 ctx <- askJSM

252 void $ liftIO $ forkIO $ handle ((`runJSM` ctx) . cb . Left) $ void . (`runJSM` ctx) $ do

251 void $ liftIO $ forkIO $ handle ((`runJSM` ctx) . cb . Left) $ void . (`runJSM` ctx) $ do

reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+1−3

@@ -9,14 +9,12 @@ module Reflex.Dom.Xhr.Foreign (

9 , module Reflex.Dom.Xhr.Foreign

10) where

12−import Control.Exception (catch, throwIO)

12+import Control.Exception (throwIO)

13import Control.Monad (join)

14import Control.Monad.IO.Class (MonadIO(..))

15import Data.Maybe (fromMaybe)

16import Data.Text (Text)

17import Data.ByteString (ByteString)

18−import GHCJS.Marshal (fromJSValUnchecked)

19−import GHCJS.DOM

20import GHCJS.DOM.Enums

18import GHCJS.DOM.Enums

21import GHCJS.DOM.EventM (EventM, on)

19import GHCJS.DOM.EventM (EventM, on)

22import GHCJS.DOM.EventTarget (dispatchEvent)

20import GHCJS.DOM.EventTarget (dispatchEvent)

reflex-dom-core/test/gc.hs+50−12

@@ -3,19 +3,57 @@

3import Control.Concurrent

4import Control.Monad

5import Control.Monad.IO.Class

6+import Data.Int

7+import GHC.Stats

6import Language.Javascript.JSaddle.Warp

8import Language.Javascript.JSaddle.Warp

7import Reflex.Dom.Core

9import Reflex.Dom.Core

8−import Reflex.Dom.Main

10+import System.Exit

11+import System.IO.Temp

12+import System.Mem

13+import System.Process

14+

15+-- In initial testing, the minimum live bytes count was 233128 and maximum was

16+-- 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+-- memory leak, but may mean the test needs to be updated.

19+minBytesAllowed, maxBytesAllowed :: Int64

20+(minBytesAllowed, maxBytesAllowed) = (200000, 400000)

10main :: IO ()

22main :: IO ()

23+main = do

24+ mainThread <- myThreadId

25+ withSystemTempDirectory "reflex-dom-core_test_gc" $ \tmp -> do

26+ browserProcess <- spawnCommand $ "xvfb-run -a chromium --user-data-dir=" ++ tmp ++ " http://localhost:3911"

27+ let finishTest result = do

28+ interruptProcessGroupOf browserProcess

29+ throwTo mainThread result

11−main = run 3911 $ do

30+ run 3911 $ do

31+ liftIO $ putStrLn "Running..."

12− mainWidget $ do

32+ mainWidget $ do

13− let w = do

33+ let w = do

14− rec let modifyAttrs = flip pushAlways (updated d) $ \_ -> sample $ current d

34+ rec let modifyAttrs = flip pushAlways (updated d) $ \_ -> sample $ current d

15− (e, _) <- element "button" (def & modifyAttributes .~ modifyAttrs) blank

35+ (e, _) <- element "button" (def & modifyAttributes .~ modifyAttrs) blank

16− d <- holdDyn mempty $ mempty <$ domEvent Click e

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

17− return ()

37+ return ()

18− redraw <- button "Redraw"

38+ postBuild <- getPostBuild

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

40+ then do performMajorGC

41+ gcStats <- getGCStats

42+ print $ currentBytesUsed gcStats

43+ when (currentBytesUsed gcStats < minBytesAllowed) $ do

44+ putStrLn "FAILED: currentBytesUsed < minBytesAllowed"

45+ finishTest $ ExitFailure 2

46+ when (currentBytesUsed gcStats > maxBytesAllowed) $ do

47+ putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"

48+ finishTest $ ExitFailure 1

49+ return $ Just $ succ n

50+ else do putStrLn "SUCCEEDED"

51+ finishTest ExitSuccess

52+ return Nothing

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

54+ [ (0 :: Int) <$ postBuild

55+ , fmapMaybe id redraw

56+ ]

19− _ <- widgetHold w $ w <$ redraw

57+ _ <- widgetHold w $ w <$ redraw

20− return ()

58+ return ()

21− liftIO $ forever $ threadDelay 1000000000

59+ liftIO $ forever $ threadDelay 1000000000

reflex-dom-core/test/hlint.hs+7

@@ -8,5 +8,12 @@ main = do

8 , "--ignore=Redundant do"

9 , "--ignore=Use camelCase"

10 , "--ignore=Redundant $"

11+ , "--ignore=Use &&"

12+ , "--ignore=Use &&&"

13+ , "--ignore=Use const"

14+ , "--ignore=Use >=>"

15+ , "--ignore=Use ."

16+ , "--ignore=Use unless"

17+ , "--cpp-define=USE_TEMPLATE_HASKELL"

11 ]

18 ]

12 if null ideas then exitSuccess else exitFailure

19 if null ideas then exitSuccess else exitFailure