@@ -1,10 +1,13 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecursiveDo #-}
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
6import Data.Int
7import Data.Int
7import GHC.Stats
8import GHC.Stats
9+import Language.Javascript.JSaddle.Types (liftJSM)
10+import Language.Javascript.JSaddle.Run
8import Language.Javascript.JSaddle.Warp
11import Language.Javascript.JSaddle.Warp
9import Reflex.Dom.Core
12import Reflex.Dom.Core
10import System.Exit
13import System.Exit
@@ -16,8 +19,8 @@ import System.Process
16-- 363712. Going over the maximum means the test has actually failed - we
19-- 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
20-- 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.
21-- memory leak, but may mean the test needs to be updated.
19−minBytesAllowed, maxBytesAllowed :: Int64
22+minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64
20−(minBytesAllowed, maxBytesAllowed) = (200000, 450000)
23+(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 440000)
22main :: IO ()
25main :: IO ()
@@ -28,6 +31,7 @@ main = do
28 interruptProcessGroupOf browserProcess
31 interruptProcessGroupOf browserProcess
29 throwTo mainThread result
32 throwTo mainThread result
30 run 3911 $ do
33 run 3911 $ do
34+ -- enableLogging True
31 liftIO $ putStrLn "Running..."
35 liftIO $ putStrLn "Running..."
32 mainWidget $ do
36 mainWidget $ do
33 let w = do
37 let w = do
@@ -36,23 +40,30 @@ main = do
36 d <- holdDyn mempty $ mempty <$ domEvent Click e
40 d <- holdDyn mempty $ mempty <$ domEvent Click e
38 postBuild <- getPostBuild
42 postBuild <- getPostBuild
39− let f n = liftIO $ if n < 3000
43+ let f (!failures, !n) = if n < 3000
40− then do performMajorGC
45+ liftIO $ performMajorGC
41− threadDelay 1000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined
46+ liftJSM $ do
47+ _ <- waitForAnimationFrame
42 gcStats <- getGCStats
50 gcStats <- getGCStats
43 print $ currentBytesUsed gcStats
51 print $ currentBytesUsed gcStats
44 when (currentBytesUsed gcStats < minBytesAllowed) $ do
52 when (currentBytesUsed gcStats < minBytesAllowed) $ do
45 putStrLn "FAILED: currentBytesUsed < minBytesAllowed"
53 putStrLn "FAILED: currentBytesUsed < minBytesAllowed"
46 finishTest $ ExitFailure 2
54 finishTest $ ExitFailure 2
47− when (currentBytesUsed gcStats > maxBytesAllowed) $ do
55+ let overMax = currentBytesUsed gcStats > maxBytesAllowed
56+ underReset = currentBytesUsed gcStats < resetThreshold
57+ when (overMax && failures > 4) $ do
48 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"
58 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"
49 finishTest $ ExitFailure 1
59 finishTest $ ExitFailure 1
50− return $ Just $ succ n
60+ return $ Just (if overMax then succ failures else (if underReset then 0 else failures), succ n)
51− else do putStrLn "SUCCEEDED"
62+ putStrLn "SUCCEEDED"
52− finishTest ExitSuccess
63+ finishTest ExitSuccess
53− return Nothing
64+ return Nothing
54 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost
65 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost
55− [ (0 :: Int) <$ postBuild
66+ [ ((0 :: Int), (0 :: Int)) <$ postBuild
56 , fmapMaybe id redraw
67 , fmapMaybe id redraw
58 _ <- widgetHold w $ w <$ redraw
69 _ <- widgetHold w $ w <$ redraw