Add new CallBufferMode: FlushPeriodically. HeinrichApfelmus#192

This mode is like `BufferRun`, but will flush the
call buffer every 300ms if nonempty.

CHANGELOG.md

@@ -9,6 +9,7 @@
 
 * Improve documentation and handling of call buffering (`CallBufferMode`). The default call buffer mode was documented incorrectly, it was  `BufferRun` and is now `FlushOften`. [#163][], [#191][], [#192][]
 * Add new default `CallBufferMode`: `FlushOften`. This mode is like `BufferRun`, but will flush the buffer at every `onEvent` as well, leading to less confusion when using the library in most circumstances. [#191][]
+* Add new `CallBufferMode`: `FlushPeriodically`. This mode is like `BufferRun`, but will flush the call buffer every 300ms if nonempty. [#192][]
 * Add support for [custom DOM events][customevent] (`CustomEvent`). [#196][]
 * Expose JavaScript FFI functions `toJSObject` and `liftJSWindow` in `Graphics.UI.Threepenny`. This is useful for linking the lifetime of JavaScript objects to the lifetime of `Element`. [#181][]
 * Use `jsLog` parameter to log exceptions. [#185][]

CONTRIBUTORS

@@ -13,6 +13,7 @@ Carsten König     <https://github.com/CarstenKoenig>
 Yuval Langer
 Ken Friis Larsen  <https://github.com/kfl>
 Felipe Lessa      <https://github.com/meteficha>
+Wesley Massuda    <https://github.com/massudaw>
 Daniel Mlot       <https://github.com/duplode>
 JP Moresmau       <https://github.com/JPMoresmau>
 Luke Palmer

src/Foreign/JavaScript.hs

@@ -32,6 +32,7 @@ module Foreign.JavaScript (
 import           Control.Concurrent.STM       as STM
 import           Control.Monad                           (unless)
 import qualified Data.Aeson                   as JSON
+import           Foreign.JavaScript.CallBuffer
 import           Foreign.JavaScript.EventLoop
 import           Foreign.JavaScript.Marshal
 import           Foreign.JavaScript.Server
@@ -65,7 +66,6 @@ serve config init = httpComm config $ eventLoop $ \w -> do
 runFunction :: Window -> JSFunction () -> IO ()
 runFunction w f = bufferRunEval w =<< toCode f
 
-
 -- | Run a JavaScript function that creates a new object.
 -- Return a corresponding 'JSObject' without waiting for the browser
 -- to send a result.
@@ -108,45 +108,3 @@ exportHandler w f = do
         ffi "Haskell.newEvent(%1,%2)" g (convertArguments f)
     Foreign.addReachable h g
     return h
-
-{-----------------------------------------------------------------------------
-    Call Buffer
-------------------------------------------------------------------------------}
--- | Set the call buffering mode for the given browser window.
-setCallBufferMode :: Window -> CallBufferMode -> IO ()
-setCallBufferMode w@Window{..} new = do
-    flushCallBuffer w
-    atomically $ writeTVar wCallBufferMode new
-
--- | Get the call buffering mode for the given browser window.
-getCallBufferMode :: Window -> IO CallBufferMode
-getCallBufferMode w@Window{..} = atomically $ readTVar wCallBufferMode
-
--- | Flush the call buffer,
--- i.e. send all outstanding JavaScript to the client in one single message.
-flushCallBuffer :: Window -> IO ()
-flushCallBuffer w@Window{..} = do
-    code' <- atomically $ do
-        code <- readTVar wCallBuffer
-        writeTVar wCallBuffer id
-        return code
-    let code = code' ""
-    unless (null code) $
-        runEval code
-
--- Schedule a piece of JavaScript code to be run with `runEval`,
--- depending on the buffering mode
-bufferRunEval :: Window -> String -> IO ()
-bufferRunEval w@Window{..} code = do
-    action <- atomically $ do
-        mode <- readTVar wCallBufferMode
-        case mode of
-            NoBuffering -> do
-                return $ Just code
-            _ -> do
-                msg <- readTVar wCallBuffer
-                writeTVar wCallBuffer (msg . (\s -> ";" ++ code ++ s))
-                return Nothing
-    case action of
-        Nothing   -> return ()
-        Just code -> runEval code

src/Foreign/JavaScript/CallBuffer.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE RecordWildCards #-}
+module Foreign.JavaScript.CallBuffer where
+
+import Control.Concurrent
+import Control.Concurrent.STM as STM
+import Control.Monad
+
+import Foreign.JavaScript.Types
+
+{-----------------------------------------------------------------------------
+    Call Buffer
+------------------------------------------------------------------------------}
+-- | Set the call buffering mode for the given browser window.
+setCallBufferMode :: Window -> CallBufferMode -> IO ()
+setCallBufferMode w@Window{..} new = do
+    flushCallBuffer w
+    atomically $ writeTVar wCallBufferMode new
+
+-- | Get the call buffering mode for the given browser window.
+getCallBufferMode :: Window -> IO CallBufferMode
+getCallBufferMode w@Window{..} = atomically $ readTVar wCallBufferMode
+
+-- | Flush the call buffer,
+-- i.e. send all outstanding JavaScript to the client in one single message.
+flushCallBuffer :: Window -> IO ()
+flushCallBuffer w@Window{..} = do
+    code' <- atomically $ do
+        code <- readTVar wCallBuffer
+        writeTVar wCallBuffer id
+        return code
+    let code = code' ""
+    unless (null code) $
+        runEval code
+
+-- Schedule a piece of JavaScript code to be run with `runEval`,
+-- depending on the buffering mode
+bufferRunEval :: Window -> String -> IO ()
+bufferRunEval w@Window{..} code = do
+    action <- atomically $ do
+        mode <- readTVar wCallBufferMode
+        case mode of
+            NoBuffering -> do
+                return $ Just code
+            _ -> do
+                msg <- readTVar wCallBuffer
+                writeTVar wCallBuffer (msg . (\s -> ";" ++ code ++ s))
+                return Nothing
+    case action of
+        Nothing   -> return ()
+        Just code -> runEval code

src/Foreign/JavaScript/EventLoop.hs

@@ -20,7 +20,8 @@ import qualified Data.Map                 as Map
 import qualified Data.Text                as T
 import qualified System.Mem
 
-import Foreign.RemotePtr        as Foreign
+import Foreign.RemotePtr             as Foreign
+import Foreign.JavaScript.CallBuffer
 import Foreign.JavaScript.Types
 
 rebug :: IO ()
@@ -47,7 +48,9 @@ type Result = Either String JSON.Value
 -- Supports concurrent invocations of `runEval` and `callEval`.
 eventLoop :: (Window -> IO void) -> (Server -> Comm -> IO ())
 eventLoop init server comm = void $ do
-    -- To support concurrent FFI calls, we make three threads.
+    -- To support concurrent FFI calls, we need three threads.
+    -- A fourth thread supports
+    --
     -- The thread `multiplexer` reads from the client and
     --   sorts the messages into the appropriate queue.
     events      <- newTQueueIO
@@ -152,7 +155,7 @@ eventLoop init server comm = void $ do
         -- run `multiplexer` and `handleCalls` concurrently
         withAsync multiplexer $ \_ ->
         withAsync handleCalls $ \_ ->
-        withAsync flushTimeout $ \_ ->
+        withAsync (flushCallBufferPeriodically w) $ \_ ->
         E.finally (init w >> handleEvents) $ do
             putStrLn "Foreign.JavaScript: Browser window disconnected."
             -- close communication channel if still necessary
@@ -162,6 +165,12 @@ eventLoop init server comm = void $ do
             m <- atomically $ readTVar disconnect
             m
 
+-- | Thread that periodically flushes the call buffer
+flushCallBufferPeriodically :: Window -> IO ()
+flushCallBufferPeriodically w =
+    forever $ threadDelay (flushPeriod*1000) >> flushCallBuffer w
+
+
 {-----------------------------------------------------------------------------
     Exports, Imports and garbage collection
 ------------------------------------------------------------------------------}

src/Foreign/JavaScript/Types.hs

@@ -250,6 +250,11 @@ data CallBufferMode
     -- client libraries and programs are encouraged to flush the buffer more often
     -- to simplify usage. Users may choose 'BufferRun' instead if they want more control
     -- over flushing the buffer.
+    | FlushPeriodically
+    -- ^ The same as 'BufferRun', except that the buffer will also be flushed
+    -- every 300ms.
+
+flushPeriod = 300 :: Int
 
 -- | Representation of a browser window.
 data Window = Window

threepenny-gui.cabal

@@ -89,7 +89,8 @@ Library
                     ,Graphics.UI.Threepenny.Widgets
                     ,Reactive.Threepenny
   other-modules:
-                     Foreign.JavaScript.EventLoop
+                     Foreign.JavaScript.CallBuffer
+                    ,Foreign.JavaScript.EventLoop
                     ,Foreign.JavaScript.Include
                     ,Foreign.JavaScript.Marshal
                     ,Foreign.JavaScript.Resources