threepenny-gui 0.7.0.2 → 0.8.0.0

raw patch · 19 files changed

+596/−230 lines, 19 filesdep +exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +52/−21
• LICENSE +1/−4
• README.md +32/−20
• js/comm.js +13/−6
• js/ffi.js +22/−16
• js/lib.js +4/−4
• samples/BarTab.hs +7/−7
• samples/Canvas.hs +3/−2
• samples/Chat.hs +2/−0
• samples/README.md +6/−1
• src/Foreign/JavaScript.hs +69/−10
• src/Foreign/JavaScript/EventLoop.hs +77/−62
• src/Foreign/JavaScript/Server.hs +71/−19
• src/Foreign/JavaScript/Types.hs +126/−18
• src/Foreign/RemotePtr.hs +1/−1
• src/Graphics/UI/Threepenny/Core.hs +22/−21
• src/Graphics/UI/Threepenny/Events.hs +10/−5
• src/Graphics/UI/Threepenny/Internal.hs +72/−12
• threepenny-gui.cabal +6/−1

@@ -1,22 +1,53 @@ ## Changelog for the `threepenny-gui` package -**0.7.0.2** -- Maintenance release+**0.8.0.0** — Snapshot release +Graphics.UI.Threepenny++* Fix `getElementById` to properly return `Nothing` when no element with the given `id` attribute is present. [#129][].+* Bring back `loadFile` and `loadDirectory`. [#110][]+* Add `MonadUI` typeclass for easier lifting in custom monad stacks. [#173][]++JavaScript FFI++* Implement batching / buffering for FFI calls. [#131][]. Several calls to the `runFunction` function may now buffer the JavaScript code and send it to the browser window in a single message at a later time. This improves performance considerably.+* Clarify semantics for exceptions. See the file [`doc/javascript-ffi.md`](doc/javascript-ffi.md) for more.+    * The `UI` monad now supports exception handling by being an instance of the type classes `MonadThrow` and `MonadCatch`.+    * The function `callFunction` can now throw a `JavaScriptException` exception to the Haskell side.+    * The function `runFunction` now terminates the connection to the browser window whenever the JavaScript code within throws an exception.+* Exceptions in the `UI` monad that are not handled are now printed properly for better debugging. [#145][]+* Clarify semantics of the `disconnect` event. It is now triggered more reliably. [#133][].+* Remove unnecessary client response when exporting event handlers. [#131][].+* Add option `jsWindowReloadOnDisconnect` to reload the browser window [#130][] whenever the WebSocket connection is broken. This is useful for e.g. mobile devices, which tend to disconnect WebSocket connections very often.++  [#110]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/110+  [#129]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/129+  [#130]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/130+  [#133]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/133+  [#145]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/145+  [#173]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/173++Dependencies++* Add dependency on `exceptions`++**0.7.0.2** — Maintenance release+ * Bump dependencies to allow `aeson` 1.2 * Bump dependencies to allow `websockets` 0.11 -**0.7.0.1** -- Maintenance release+**0.7.0.1** — Maintenance release  * Bump dependencies to allow `aeson` 1.1 * Bump dependencies to allow `vector` 0.12 * Bump dependencies to allow `websockets` 0.10 -**0.7.0.0** -- Maintenance and snapshot release+**0.7.0.0** — Maintenance and snapshot release -* Reduce communication from browser to server when creating `Element`s.+* JavaScript FFI: Reduce communication from browser to server when creating `Element`s.     New function `unsafeCreateJSObject` to create JavaScript objects without     waiting for a client response. [#131][]-* Implement escape sequence '%%' for JavaScript FFI. [#132][].+* JavaScript FFI: Implement escape sequence '%%' when calling JavaScript functions. [#132][]. * Change type of `onEvent` function to allow unregistering events. * Add function `timestamp` for simple performance measurements. * Update JavaScript dependencies to jQuery 2.2.3@@ -25,23 +56,23 @@ * Bump dependencies to allow `data-default` 0.7 * Bump dependencies to allow `snap-core` 1.0 and `snap-server` 1.0 * Bump dependencies to allow `template-haskell` 2.11-* Bump dependencies to allow `websockest-snap` 0.10+* Bump dependencies to allow `websockets-snap` 0.10    [#131]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/131   [#132]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/132   [#138]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/138 -**0.6.0.6** -- Maintenance release+**0.6.0.6** — Maintenance release  * Bump dependencies to allow `base` 4.9 * Bump dependencies to allow `aeson` 0.11 -**0.6.0.5** -- Maintenance release+**0.6.0.5** — Maintenance release  * Bump dependencies to allow `async` 2.1 * Bump dependencies to allow `transformers` 0.5 -**0.6.0.4** -- Maintenance release.+**0.6.0.4** — Maintenance release.  * Elements that have become unreachable, for instance because they have been removed from the DOM and are no longer reachable in the Haskell code, will be garbage collected again. Fix [#109][], [#113][]. * Adjust dependencies.@@ -51,11 +82,11 @@   [#109]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/109   [#116]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/116 -**0.6.0.3** -- Maintenance release.+**0.6.0.3** — Maintenance release.  * Temporary fix for #109, which was causing event handlers to be discarded. Unfortunately, this means that elements are currently not garbage collected after they have been removed from the DOM tree. -**0.6.0.2** -- Maintenance release.+**0.6.0.2** — Maintenance release.  * Remove unused direct dependencies, in particular ** attoparsec-enumerator@@ -63,19 +94,19 @@ ** MonadCatchIO-transformers ** time -**0.6.0.1** -- Maintenance release.+**0.6.0.1** — Maintenance release.  * The `ADDR` environment variable is now parsed correctly. * Now builds on GHC 7.8 and GHC 7.10 * The example source code in the `samples` folder has been reorganized and consolidated. -**0.6.0.0** -- Snapshot release.+**0.6.0.0** — Snapshot release.  * The internals of the JavaScript FFI has been reimplemented completely. A new module `Foreign.JavaScript` exports a bare JavaScript FFI in case you want to write a custom GUI framework. However, the module `Graphics.UI.Threepenny` is *not* compatible with it, even though it builds on top of it. * The fields of `Config` type for server configuration are now prefixed with `js` instead of `tp`. Example: `jsPort`, `jsStatic`. * The functions `loadFile` and `loadDirectory` have been *removed*, as I felt that the `jsStatic` option is sufficient for most use cases. -**0.5.0.0** -- Snapshot release.+**0.5.0.0** — Snapshot release.  * Possibility to specify IP address to bind the server to. * FFI now supports callbacks into Haskell. Remove `callDeferredFunction` function.@@ -84,7 +115,7 @@ * `Bool` is now correctly marshalled to JavaScript. * `Text` can now be marshalled to JavaScrtip. -**0.4.2.0** -- Maintenance release.+**0.4.2.0** — Maintenance release.  * Dependency `bytestring >=0.9.2` is now implemented correctly. * Allow newer versions of `aeson` dependency.@@ -92,22 +123,22 @@ * Helper scripts in the `samples` directory now assume that you use a cabal sandbox for development. * The `UI` monad is now an instance of the `Applicative` class. -**0.4.1.0** -- Maintenance release.+**0.4.1.0** — Maintenance release.  * Dependency on `text` package now from version 0.11 to 1.1.*. * Dependency on `aeson` package replaces the former dependency on the `json` package. * Unicode characters are now transmitted correctly to the browser. #75, #62. * Change default port number to 8023. #64 -**0.4.0.2** -- Bugfix release.+**0.4.0.2** — Bugfix release.  * Fix CSS bug for `grid` function. -**0.4.0.1** -- Maintenance release.+**0.4.0.1** — Maintenance release.  * Adjust package dependencies. -**0.4.0.0** -- Snapshot release.+**0.4.0.0** — Snapshot release.  * New `UI` monad for easier JavaScript FFI and recursion in FRP. * Garbage collection for DOM elements. (Unfortunately, this doesn't support using custom HTML files anymore, see [issue #60][#60].)@@ -116,12 +147,12 @@    [#60]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/60 -**0.3.0.0** -- Snapshot release.+**0.3.0.0** — Snapshot release.  * Browser communication with WebSockets. * First stab at FRP integration. -**0.2.0.0** -- Snapshot release.+**0.2.0.0** — Snapshot release.  * First stab at easy JavaScript FFI. 

@@ -5,10 +5,7 @@  -- -Copyright (c) 2013, Heinrich Apfelmus <https://github.com/HeinrichApfelmus/>-Copyright (c) 2013, Daniel Austin     <https://github.com/daniel-r-austin>-Copyright (c) 2013, Daniel Mlot       <https://github.com/duplode>-Copyright (c) 2013, Rnons             <https://github.com/rnons>+Copyright (c) 2012-2016, Threepenny-GUI authors (see CONTRIBUTORS) Copyright (c) 2012, Jeremy Bowers     <https://github.com/thejerf> Copyright (c) 2011-2012, Chris Done   <https://github.com/chrisdone> All rights reserved.

@@ -1,38 +1,48 @@-[![Build Status](https://travis-ci.org/HeinrichApfelmus/threepenny-gui.png)](https://travis-ci.org/HeinrichApfelmus/threepenny-gui)+[![Travis Build Status](https://travis-ci.org/HeinrichApfelmus/threepenny-gui.svg)](https://travis-ci.org/HeinrichApfelmus/threepenny-gui)+[![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/HeinrichApfelmus/threepenny-gui?svg=true)](https://ci.appveyor.com/project/HeinrichApfelmus/threepenny-gui)+[![Hackage](https://img.shields.io/hackage/v/threepenny-gui.svg)](https://hackage.haskell.org/package/threepenny-gui)+[![Stackage LTS](http://stackage.org/package/threepenny-gui/badge/lts)](http://stackage.org/lts/package/threepenny-gui)+[![Stackage Nightly](http://stackage.org/package/threepenny-gui/badge/nightly)](http://stackage.org/nightly/package/threepenny-gui) -Threepenny-gui is a GUI framework written in Haskell that uses the web browser as a display. It's very easy to install. See the+# Threepenny-GUI +### What's this?++Threepenny is a GUI framework written in Haskell that uses the web browser as a display. It's very easy to install. See the+   [**Project homepage**](http://wiki.haskell.org/Threepenny-gui)  for more information on what it does and can do for you as a library user. -## Examples+### Examples -The library comes with many examples, which can be found in the [samples](https://github.com/HeinrichApfelmus/threepenny-gui/tree/master/samples#readme) folder. Follow the link for more information on how to run them.+The library comes with many examples, which can be found in the [samples](samples#readme) folder. Follow the link for more information on how to run them. -## Technical overview+### Desktop Apps +Threepenny is mainly intended for writing GUI applications that run on the local network, and it relies on a web browser being installed. You can drop the latter requirement and integrate it a bit more tightly with you desktop environment by using the Electron framework. There is no fully automated support for this yet, but the documentation includes a [tutorial on how to use Electron with Threepenny](doc/electron.md).++# Technical overview++### JavaScript FFI+ A program written with Threepenny is essentially a small web server that displays the user interface as a web page to any browser that connects to it. +The web server displays a HTML page, which in turn establishes WebSocket connection with the server. The server uses this connection to send JavaScript code that is executed in the client. In the library, this appears as a JavaScript Foreign Function Interface (FFI). The documentation includes [more information on the design of the JavaScript FFI](doc/javascript-ffi.md).+ ### Latency  The frequent communication between browser and server-means that Threepenny is best used as a GUI server running on localhost.--The communication is done over a persistent connection using WebSockets.--If you want to reduce latency, the best option is to generate JavaScript-code and run it on the client. Consider this approach similar to [a-shading language](http://en.wikipedia.org/wiki/Shading_language). Some means of producing JavaScript from Haskell might be:+means that Threepenny is best used as a GUI server running on localhost. You can use it on your local network as well. -* Fay-* HJScript-* GHCJS-* UHC+If you want to reduce latency, the best option is to generate larger blocks of JavaScript+code and run them on the client. Consider this approach similar to [a+shading language](http://en.wikipedia.org/wiki/Shading_language).+You can import any JavaScript library and use it from the JavaScript FFI. -Alternatively, the JS can be written by the user directly and invoked via the JavaScript FFI from Threepenny.+If you don't want to write JavaScript, then you could choose a Haskell-like language like [PureScript](http://www.purescript.org), [Fay](https://github.com/faylang/fay/wiki). You can also directly compile JavaScript to Haskell with [Haste](https://github.com/valderman/haste-compiler) or [GHCJS](https://github.com/ghcjs/ghcjs). -## Future ideas+# Future ideas  ### HTML rendering mode @@ -45,10 +55,12 @@ There are plenty more like this, but this is the first that springs to mind that is good. -## Contributors+# Contributors  Many thanks to everyone who contributed, provided feedback or simply wrote an application using Threepenny! In particular, many thanks to: -Heinrich Apfelmus, Daniel Austin, Steve Bigham, Ken Friis Larsen, Daniel Mlot, Tim C. Schröder *and also* Daniel Diaz, Alex Greif, Yuval Langer, JP Moresmau, Luke Palmer, Jens Peterson, Jaap van der Plas, rnons, Michael Snoyman, tailcalled+Heinrich Apfelmus, Daniel Austin, Jeremy Barisch-Rooney, Steve Bigham, Simon Jakobi, Ken Friis Larsen, Daniel Mlot, Tim C. Schröder [*and many others*](CONTRIBUTORS)++Special thanks to *Simon Jakobi* for co-maintaining this project.  Special thanks to *Chris Done* for starting the precursor project Ji.

@@ -14,7 +14,8 @@ ********************************************************************* */ Haskell.createWebSocket = function (url0, receive) {   var that = {};-  var url  = 'ws:' + url0.slice(5) + 'websocket/';+  var optReloadOnDisconnect = false;+  var url  = 'ws:' + url0.slice(5) + '/websocket/';   var ws   = new WebSocket(url);      // Close WebSocket when the browser window is closed.@@ -25,8 +26,11 @@   // Send ping message in regular intervals.   // We expect pong messages in return to keep the connection alive.   var ping = function () {-    ws.send("ping");-    window.setTimeout(ping,2000);+    // Only send a ping when it has a chance to reach the server.+    if (ws.readyState !== WebSocket.CLOSING && ws.readyState !== WebSocket.CLOSED) {+      ws.send("ping");+      window.setTimeout(ping,2000);+    }   };      // Start communication when the WebSocket is opened.@@ -40,6 +44,7 @@     };     ws.onclose = function (e) {       Haskell.log("WebSocket closed: %o", e);+      if (optReloadOnDisconnect) { window.location.reload(true); }     };     ws.onerror = function (e) {       Haskell.log("WebSocket error: %o", e);@@ -47,9 +52,11 @@   };      // Send a JSON message to the server-  that.send = function (json) {-    ws.send(JSON.stringify(json));-  };+  that.send  = function (json) { ws.send(JSON.stringify(json)); };+  // Close the connection+  that.close = function () { ws.send("quit"); };+  // Set option: Reload window when the websocket connection is broken?+  that.setReloadOnDisconnect = function (b) { optReloadOnDisconnect = b };      return that; };

@@ -15,7 +15,7 @@ // An optional string argument can be used to specify the server URL. Haskell.initFFI = function () {   var connection;-  var url = window.location.href.toString();+  var url = window.location.origin.toString();    if (arguments[0]) {     url = arguments[0]; // take server url from argument@@ -33,31 +33,37 @@     Haskell.log("Server message: %o", msg);      switch (msg.tag) {-      case "RunEval" : {++      case "RunEval":+        try {           eval(msg.contents);           reply();-          break;-      }-      case "CallEval" : {-          var result   = eval(msg.contents);-          reply({-            tag      : "Result",-            contents : result-          });-          break;-      }-      case "Debug": {+        } catch (err) {+          connection.close();+          throw(err);+        }+        break;++      case "CallEval":+        try {+          var result = eval(msg.contents);+          reply({ tag : "Result"   , contents : result });+        } catch (err) {+          reply({ tag : "Exception", contents : err.toString() });+        }+        break;++      case "Debug":         Haskell.log("Server debug: %o", msg.contents);         reply();         break;-      }-      case "Timestamp": {++      case "Timestamp":         Haskell.log("Timestamp: %f ms", Haskell.performance.now());         Haskell.log("Elapsed since last timestamp: %f ms",           Haskell.performance.diff());         reply();         break;-      }     }   }; 

@@ -1,6 +1,6 @@ /* *********************************************************************   Threepenny - JavaScript library-  +   Additional JavaScript functions that are available   for Threepenny. ********************************************************************* */@@ -34,7 +34,7 @@             ? [e.originalEvent.dataTransfer.getData("dragData")]             : [] );     });-  } else if(eventType.match('mousemove|mousedown|mouseup')) {+  } else if(eventType.match('contextmenu|mousemove|mousedown|mouseup')) {     $(el).bind(eventType, function(e) {       var offset = $(this).offset();       var x      = e.pageX - offset.left;@@ -58,7 +58,7 @@ ///////////////////////////////////////////////////////////////////// // Canvas API additions. // See http://stackoverflow.com/a/9722502/403805 .-CanvasRenderingContext2D.prototype.clear = +CanvasRenderingContext2D.prototype.clear =   CanvasRenderingContext2D.prototype.clear || function (preserveTransform) {     if (preserveTransform) {       this.save();@@ -67,7 +67,7 @@     this.clearRect(0, 0, this.canvas.width, this.canvas.height);     if (preserveTransform) {       this.restore();-    }           +    } };  

@@ -23,13 +23,13 @@     elResult <- UI.span      inputs   <- liftIO $ newIORef []-    +     -- functionality     let         displayTotal = void $ do             xs <- mapM (get value) =<< liftIO (readIORef inputs)-            element elResult # set text (showNumber . sum $ map readNumber xs)-        +            element elResult # set UI.text (showNumber . sum $ map readNumber xs)+         redoLayout :: UI ()         redoLayout = void $ do             layout <- mkLayout =<< liftIO (readIORef inputs)@@ -44,16 +44,16 @@             [UI.hr             ,row [UI.span # set text "Sum: ", element elResult]             ]-        +         addInput :: UI ()         addInput = do             elInput <- UI.input # set value "0"             on (domEvent "livechange") elInput $ \_ -> displayTotal             liftIO $ modifyIORef inputs (elInput:)-        +         removeInput :: UI ()         removeInput = liftIO $ modifyIORef inputs (drop 1)-    +     on UI.click elAdd    $ \_ -> addInput    >> redoLayout     on UI.click elRemove $ \_ -> removeInput >> redoLayout     addInput >> redoLayout@@ -73,5 +73,5 @@     fromInteger = pure . fromInteger  readNumber :: String -> Number-readNumber s = listToMaybe [x | (x,"") <- reads s]    +readNumber s = listToMaybe [x | (x,"") <- reads s] showNumber   = maybe "--" show

@@ -12,7 +12,7 @@ main :: IO () main = do     static <- getStaticDir-    startGUI defaultConfig { jsStatic = Just static } setup+    startGUI defaultConfig setup  canvasSize = 400 @@ -100,7 +100,8 @@         canvas # UI.fillText   "is awesome" (140,60)      -- draw the haskell logo-    img <- UI.img # set UI.src "static/haskell-logo.png"+    url <- UI.loadFile "image/png" "static/haskell-logo.png"+    img <- UI.img # set UI.src url      on UI.click drawImage $ const $ do         canvas # UI.drawImage img (60,20)

@@ -30,6 +30,7 @@  setup :: Chan Message -> Window -> UI () setup globalMsgs window = do+    UI.setCallBufferMode BufferRun     msgs <- liftIO $ Chan.dupChan globalMsgs      return window # set title "Chat"@@ -60,6 +61,7 @@         runUI w $ do           element messageArea #+ [mkMessage msg]           UI.scrollToBottom messageArea+          flushCallBuffer -- make sure that JavaScript functions are executed  mkMessageArea :: Chan Message -> IORef String -> UI Element mkMessageArea msgs nickname = do

@@ -26,7 +26,7 @@   [stack]: http://haskellstack.org   [cabal sandbox]: http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html -Here a description of the currently maintained examples. The others are probably experimental or bitrotted.+Here a description of the currently maintained examples.  * [BarTab.hs](BarTab.hs) — Dynamic creation of widgets. * [Buttons.hs](Buttons.hs) — Simple buttons to click on.@@ -40,3 +40,8 @@ * [GetElementsBy.hs](GetElementsBy.hs) — Get elements by tag name or ID. * [Mouse.hs](Mouse.hs) — Test of the `mousemove` event. * [Svg.hs](Svg.hs) — Test of the SVG elements.++There are also a few other examples that are used for testing or that demonstrate library internals. They won't be maintained.++* [WorkaroundFastEvent.hs](WorkaroundFastEvent.hs) — Demonstrates how to register an event handler without requiring a response from the browser window.+

@@ -6,22 +6,29 @@     -- This module implements a web server that communicates with     -- a web browser and allows you to execute arbitrary JavaScript code on it.     ---    -- Note: This module is used internally by the "Graphics.UI.Threepenny"+    -- NOTE: This module is used internally by the "Graphics.UI.Threepenny"     -- library, but the types are /not/ compatible.     -- Use "Foreign.JavaScript" only if you want to roll your own     -- interface to the web browser.      -- * Server-    serve, Config(..), defaultConfig,-    Window, root,+    serve, defaultConfig, Config(+          jsPort, jsAddr, jsWindowReloadOnDisconnect+        , jsCustomHTML, jsStatic, jsLog),+    Server, MimeType, URI, loadFile, loadDirectory,+    Window, getServer, root,      -- * JavaScript FFI-    ToJS(..), FromJS, JSFunction, JSObject,-    FFI, ffi, runFunction, callFunction, NewJSObject, unsafeCreateJSObject,+    ToJS(..), FromJS, JSFunction, JSObject, JavaScriptException,+    FFI, ffi, runFunction, callFunction,+    NewJSObject, unsafeCreateJSObject,+    CallBufferMode(..), setCallBufferMode, flushCallBuffer,     IsHandler, exportHandler, onDisconnect,     debug, timestamp,     ) where +import           Control.Concurrent.STM       as STM+import           Control.Monad                           (unless) import qualified Data.Aeson                   as JSON import           Foreign.JavaScript.EventLoop import           Foreign.JavaScript.Marshal@@ -37,15 +44,25 @@     :: Config               -- ^ Configuration options.     -> (Window -> IO ())    -- ^ Initialization whenever a client connects.     -> IO ()-serve config init = httpComm config (eventLoop init)+serve config init = httpComm config $ eventLoop $ \w -> do+    runFunction w $+        ffi "connection.setReloadOnDisconnect(%1)" $ jsWindowReloadOnDisconnect config+    flushCallBuffer w   -- make sure that all `runEval` commands are executed+    init w+    flushCallBuffer w   -- make sure that all `runEval` commands are executed  {-----------------------------------------------------------------------------     JavaScript ------------------------------------------------------------------------------} -- | Run a JavaScript function, but do not wait for a result.+--+-- NOTE: The JavaScript function need not be executed immediately,+-- it can be buffered and sent to the browser window at a later time.+-- See 'setCallBufferMode' and 'flushCallBuffer' for more. runFunction :: Window -> JSFunction () -> IO ()-runFunction w f = runEval w =<< toCode f+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.@@ -55,12 +72,16 @@ unsafeCreateJSObject :: Window -> JSFunction NewJSObject -> IO JSObject unsafeCreateJSObject w f = do     g <- wrapImposeStablePtr w f-    runEval w =<< toCode g+    bufferRunEval w =<< toCode g     marshalResult g w JSON.Null  -- | Call a JavaScript function and wait for the result. callFunction :: Window -> JSFunction a -> IO a callFunction w f = do+    -- FIXME: Add the code of f to the buffer as well!+    -- However, we have to pay attention to the semantics of exceptions in this case.+    flushCallBuffer w+     resultJS <- callEval w =<< toCode f     marshalResult f w resultJS @@ -79,8 +100,46 @@ -- keep it alive. exportHandler :: IsHandler a => Window -> a -> IO JSObject exportHandler w f = do-    g <- newHandler w (handle f w)-    h <- callFunction w $+    g <- newHandler w (\args -> handle f w args >> flushCallBuffer w)+    h <- unsafeCreateJSObject w $         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++-- | 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+            BufferRun -> do+                msg <- readTVar wCallBuffer+                writeTVar wCallBuffer (msg . (\s -> ";" ++ code ++ s))+                return Nothing+            NoBuffering -> do+                return $ Just code+    case action of+        Nothing   -> return ()+        Just code -> runEval code

@@ -10,7 +10,8 @@ import           Control.Concurrent import           Control.Concurrent.Async import           Control.Concurrent.STM   as STM-import           Control.Exception        as E    (finally)+import           Control.DeepSeq                  (deepseq)+import           Control.Exception        as E import           Control.Monad import qualified Data.Aeson               as JSON import           Data.IORef@@ -32,52 +33,62 @@     Event Loop ------------------------------------------------------------------------------} -- | Handle a single event-handleEvent w@(Window{..}) (name, args, consistency) = do+handleEvent w@(Window{..}) (name, args) = do     mhandler <- Foreign.lookup name wEventHandlers     case mhandler of         Nothing -> return ()         Just f  -> withRemotePtr f (\_ f -> f args)  +type Result = Either String JSON.Value+ -- | Event loop for a browser window. -- Supports concurrent invocations of `runEval` and `callEval`.-eventLoop :: (Window -> IO void) -> (Comm -> IO ())-eventLoop init comm = do+eventLoop :: (Window -> IO void) -> (Server -> Comm -> IO ())+eventLoop init server comm = void $ do     -- To support concurrent FFI calls, we make three threads.     -- The thread `multiplexer` reads from the client and      --   sorts the messages into the appropriate queue.     events      <- newTQueueIO-    results     <- newTQueueIO :: IO (TQueue JSON.Value)+    results     <- newTQueueIO :: IO (TQueue Result)     -- The thread `handleCalls` executes FFI calls     --    from the Haskell side in order.     -- The corresponding queue records `TMVar`s in which to put the results.-    calls       <- newTQueueIO :: IO (TQueue (Maybe (TMVar JSON.Value), ServerMsg))+    calls       <- newTQueueIO :: IO (TQueue (Maybe (TMVar Result), ServerMsg))     -- The thread `handleEvents` handles client Events in order. -    -- Events will be queued (and labelled `Inconsistent`) whenever-    -- the server is-    --    * busy handling an event-    --    * or waiting for the result of a function call.-    handling    <- newTVarIO False-    calling     <- newTVarIO False+    -- We only want to make an FFI call when the connection browser<->server is open+    -- Otherwise, throw an exception.+    let atomicallyIfOpen stm = do+            r <- atomically $ do+                b <- readTVar $ commOpen comm+                if b then fmap Right stm else return (Left ())+            case r of+                Right a -> return a+                Left  _ -> throwIO $ ErrorCall "Foreign.JavaScript: Browser <-> Server communication broken."      -- FFI calls are made by writing to the `calls` queue.-    w0 <- newPartialWindow-    let run msg = do-            atomically $ writeTQueue calls (Nothing , msg)-        call msg = do+    let run  msg = msg `deepseq` do     -- see [ServerMsg strictness]+            atomicallyIfOpen $ writeTQueue calls (Nothing , msg)+        call msg = msg `deepseq` do     -- see [ServerMsg strictness]             ref <- newEmptyTMVarIO-            atomically $ writeTQueue calls (Just ref, msg)-            atomically $ takeTMVar ref-        debug    s = do-            atomically $ writeServer comm $ Debug s+            atomicallyIfOpen $ writeTQueue calls (Just ref, msg)+            er  <- atomicallyIfOpen $ takeTMVar ref+            case er of+                Left  e -> E.throwIO $ JavaScriptException e+                Right x -> return x+        debug s  = s `deepseq` do       -- see [ServerMsg strictness]+            atomicallyIfOpen $ writeServer comm $ Debug s      -- We also send a separate event when the client disconnects.     disconnect <- newTVarIO $ return ()+    -- FIXME: Make it possible to store *multiple* event handlers     let onDisconnect m = atomically $ writeTVar disconnect m-    -    let w = w0 { runEval        = run  . RunEval-               , callEval       = call . CallEval++    w0 <- newPartialWindow+    let w = w0 { getServer    = server+               , runEval      = run  . RunEval+               , callEval     = call . CallEval                , debug        = debug                , timestamp    = run Timestamp                , onDisconnect = onDisconnect@@ -87,60 +98,64 @@     --     -- Read client messages and send them to the     -- thread that handles events or the thread that handles FFI calls.-    let multiplexer = do-            m <- untilJustM $ atomically $ do-                msg <- readClient comm-                case msg of-                    Event x y -> do-                        b <- (||) <$> readTVar handling <*> readTVar calling-                        let c = if b then Inconsistent else Consistent-                        writeTQueue events (x,y,c)-                        return Nothing-                    Result x  -> do-                        writeTQueue results x-                        return Nothing-                    Quit      -> Just <$> readTVar disconnect-            m-        +    let multiplexer = forever $ atomically $ do+            msg <- readClient comm+            case msg of+                Event x y   -> writeTQueue events (x,y)+                Result x    -> writeTQueue results (Right x)+                Exception e -> writeTQueue results (Left  e)+     -- Send FFI calls to client and collect results     let handleCalls = forever $ do             ref <- atomically $ do                 (ref, msg) <- readTQueue calls-                writeTVar calling True                 writeServer comm msg                 return ref-            atomically $ do-                writeTVar calling False+            atomically $                 case ref of                     Just ref -> do                         result <- readTQueue results                         putTMVar ref result                     Nothing  -> return ()-    +     -- Receive events from client and handle them in order.     let handleEvents = do-            init w-            forever $ do-                e <- atomically $ do-                    writeTVar handling True-                    readTQueue events-                handleEvent w e-                rebug-                atomically $ writeTVar handling False--    -- Foreign.addFinalizer (wRoot w) $ putStrLn "wRoot garbage collected."-    Foreign.withRemotePtr (wRoot w) $ \_ _ -> do    -- keep root alive-        E.finally-            (foldr1 race_ [multiplexer, handleEvents, handleCalls])-            (commClose comm)+            me <- atomically $ do+                open <- readTVar $ commOpen comm+                if open+                    then Just <$> readTQueue events+                    else return Nothing -- channel is closed+            case me of+                Nothing -> return ()    -- channel is closed, we're done+                Just e  -> do+                    handleEvent w e+                        `E.onException` commClose comm -- close channel in case of exception+                    rebug+                    handleEvents -    return ()+    -- NOTE: Due to an issue with `snap-server` library,+    -- we print the exception ourselves.+    printException $+        -- Wrap the main loop into `withRemotePtr` in order to keep the root alive.+        Foreign.withRemotePtr (wRoot w) $ \_ _ ->+        -- run `multiplexer` and `handleCalls` concurrently+        withAsync multiplexer $ \_ ->+        withAsync handleCalls $ \_ ->+        E.finally (init w >> handleEvents) $ do+            putStrLn "Foreign.JavaScript: Browser window disconnected."+            -- close communication channel if still necessary+            commClose comm                +            -- trigger the `disconnect` event+            -- FIXME: Asynchronous exceptions should not be masked during the disconnect handler+            m <- atomically $ readTVar disconnect+            m --- | Repeat an action until it returns 'Just'. Similar to 'forever'.-untilJustM :: Monad m => m (Maybe a) -> m a-untilJustM m = m >>= \x -> case x of-    Nothing -> untilJustM m-    Just a  -> return a+-- | Execute an IO action, but also print any exceptions that it may throw.+-- (The exception is rethrown.)+printException :: IO a -> IO a+printException = E.handle $ \e -> do+    putStrLn $ show (e :: E.SomeException)+    E.throwIO e  {-----------------------------------------------------------------------------     Exports, Imports and garbage collection

@@ -1,17 +1,20 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Foreign.JavaScript.Server (-    httpComm+    httpComm, loadFile, loadDirectory,     ) where  -- import general libraries+import           Control.Applicative import           Control.Concurrent import           Control.Concurrent.Async import           Control.Concurrent.STM     as STM import qualified Control.Exception          as E import           Control.Monad+import           Control.Monad.IO.Class import           Data.ByteString                    (ByteString) import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Map                   as M import           Data.Text import qualified Safe                       as Safe import           System.Environment@@ -34,7 +37,7 @@     HTTP Server using WebSockets ------------------------------------------------------------------------------} -- | Run a HTTP server that creates a 'Comm' channel.-httpComm :: Config -> (Comm -> IO ()) -> IO ()+httpComm :: Config -> (Server -> Comm -> IO ()) -> IO () httpComm Config{..} worker = do     env <- getEnvironment     let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env@@ -45,9 +48,12 @@                $ Snap.setErrorLog  (Snap.ConfigIoLog jsLog)                $ Snap.setAccessLog (Snap.ConfigIoLog jsLog)                $ Snap.defaultConfig+               +    server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths+     Snap.httpServe config . route $-        routeResources jsCustomHTML jsStatic-        ++ routeWebsockets worker+        routeResources server jsCustomHTML jsStatic+        ++ routeWebsockets (worker server)  -- | Route the communication between JavaScript and the server routeWebsockets :: (Comm -> IO void) -> Routes@@ -64,6 +70,7 @@     connection <- WS.acceptRequest request     commIn     <- STM.newTQueueIO   -- outgoing communication     commOut    <- STM.newTQueueIO   -- incoming communication+    commOpen   <- STM.newTVarIO True      -- write data to browser     let sendData = forever $ do@@ -76,24 +83,32 @@             input <- WS.receiveData connection             case input of                 "ping" -> WS.sendTextData connection . LBS.pack $ "pong"-                "quit" -> E.throw WS.ConnectionClosed+                "quit" -> E.throwIO WS.ConnectionClosed                 input  -> case JSON.decode input of                     Just x   -> atomically $ STM.writeTQueue commIn x                     Nothing  -> error $                         "Foreign.JavaScript: Couldn't parse JSON input"                         ++ show input-    -    let manageConnection = do-            withAsync sendData $ \_ -> do-            Left e <- waitCatch =<< async readData-            atomically $ STM.writeTQueue commIn $-                JSON.object [ "tag" .= ("Quit" :: Text) ] -- write Quit event-            E.throw e -    thread <- forkFinally manageConnection-        (\_ -> WS.sendClose connection $ LBS.pack "close")-    let commClose = killThread thread+    -- block until the channel is closed+    let sentry = atomically $ do+            open <- STM.readTVar commOpen+            when open retry +    -- explicitly close the Comm chanenl+    let commClose = atomically $ STM.writeTVar commOpen False++    -- read/write data until an exception occurs or the channel is no longer open+    forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do+        -- close the communication channel explicitly if that didn't happen yet+        commClose++        -- attempt to close websocket if still necessary/possible+        -- ignore any exceptions that may happen if it's already closed+        let all :: E.SomeException -> Maybe ()+            all _ = Just ()+        E.tryJust all $ WS.sendClose connection $ LBS.pack "close"+     return $ Comm {..}  {-----------------------------------------------------------------------------@@ -101,20 +116,24 @@ ------------------------------------------------------------------------------} type Routes = [(ByteString, Snap ())] -routeResources :: Maybe FilePath -> Maybe FilePath -> Routes-routeResources customHTML staticDir =+routeResources :: Server -> Maybe FilePath -> Maybe FilePath -> Routes+routeResources server customHTML staticDir =     fixHandlers noCache $         static ++         [("/"            , root)         ,("/haskell.js"  , writeTextMime jsDriverCode  "application/javascript")         ,("/haskell.css" , writeTextMime cssDriverCode "text/css")+        ,("/file/:name"                ,+            withFilepath (sFiles server) (flip serveFileAs))+        ,("/dir/:name"                 ,+            withFilepath (sDirs  server) (\path _ -> serveDirectory path))         ]     where     fixHandlers f routes = [(a,f b) | (a,b) <- routes]     noCache h = modifyResponse (setHeader "Cache-Control" "no-cache") >> h-    +     static = maybe [] (\dir -> [("/static", serveDirectory dir)]) staticDir-    +     root = case customHTML of         Just file -> case staticDir of             Just dir -> serveFile (dir </> file)@@ -124,3 +143,36 @@ writeTextMime text mime = do     modifyResponse (setHeader "Content-type" mime)     writeText text++-- | Extract  from a URI+withFilepath :: MVar Filepaths -> (FilePath -> ByteString -> Snap a) -> Snap a+withFilepath rDict cont = do+    mName    <- getParam "name"+    (_,dict) <- liftIO $ withMVar rDict return+    case (\key -> M.lookup key dict) =<< mName of+        Just (path,mimetype) -> cont path (BS.pack mimetype)+        Nothing              -> error $ "File not loaded: " ++ show mName++-- FIXME: Serving large files fails with the exception+-- System.SendFile.Darwin: invalid argument (Socket is not connected)++-- | Associate an URL to a FilePath+newAssociation :: MVar Filepaths -> (FilePath, MimeType) -> IO String+newAssociation rDict (path,mimetype) = do+    (old, dict) <- takeMVar rDict+    let new = old + 1; key = show new ++ takeFileName path+    putMVar rDict $ (new, M.insert (BS.pack key) (path,mimetype) dict)+    return key++-- | Begin to serve a local file with a given 'MimeType' under a URI.+loadFile :: Server -> MimeType -> FilePath -> IO String+loadFile server mimetype path = do+    key <- newAssociation (sFiles server) (path, mimetype)+    return $ "/file/" ++ key++-- | Begin to serve a local directory under a URI.+loadDirectory :: Server -> FilePath -> IO String+loadDirectory server path = do+    key <- newAssociation (sDirs server) (path,"")+    return $ "/dir/" ++ key+

@@ -1,7 +1,8 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Foreign.JavaScript.Types where  import           Control.Applicative+import qualified Control.Exception       as E import           Control.Concurrent.STM  as STM import           Control.Concurrent.Chan as Chan import           Control.Concurrent.MVar@@ -13,14 +14,53 @@ import           Data.Map                as Map import           Data.String import           Data.Text+import           Data.Typeable import           System.IO                       (stderr)  import Foreign.RemotePtr  {------------------------------------------------------------------------------    Server Configuration+    Server Configuration -- Static ------------------------------------------------------------------------------}--- | Configuration of a "Foreign.JavaScript" server.+-- NOTE: Unfortunately, Haddock currently does not create documentation for+-- record fields when the constructor is not exported.+-- That's why we copy & paste it in the documentation for the data type.+{- | Static configuration for a "Foreign.JavaScript" server.++This is a record type which has the following fields:++* @jsPort :: Maybe Int@          ++    Port number.+    @Nothing@ means that the port number is read from the environment variable @PORT@.+    Alternatively, port @8023@ is used if this variable is not set.++* @jsAddr :: Maybe ByteString@++    Bind address.+    @Nothing@ means that the bind address is read from the environment variable @ADDR@.+    Alternatively, address @127.0.0.1@ is used if this variable is not set.++* @jsWindowReloadOnDisconnect :: Bool@++    Reload the browser window if the connection to the server was dropped accidentally,+    for instance because the computer was put to sleep and awoken again.++* @jsCustomHTML :: Maybe FilePath@++    Custom HTML file to replace the default one.++* @jsStatic :: Maybe FilePath@++    Directory that is served under @/static@.++* @jsLog :: ByteString -> IO ()@++    Function to print a single log message.++(For reasons of forward compatibility, the constructor is not exported.)++-} data Config = Config     { jsPort       :: Maybe Int                    -- ^ Port number.@@ -33,6 +73,10 @@         -- read from the environment variable @ADDR@.         -- Alternatively, address @127.0.0.1@ is         -- used if this variable is not set.+    , jsWindowReloadOnDisconnect :: Bool+        -- ^ Reload the browser window if the connection to the server was dropped+        -- accidentally,+        -- for instance because the computer was put to sleep and awoken again.     , jsCustomHTML :: Maybe FilePath         -- ^ Custom HTML file to replace the default one.     , jsStatic     :: Maybe FilePath@@ -49,26 +93,50 @@  -- | Default configuration. ----- Port from environment variable or @8023@,--- listening on @localhost@, no custom HTML, no static directory,+-- Port from environment variable or @8023@, listening on @localhost@,+-- do reload on disconnect,+-- no custom HTML, no static directory, -- logging to stderr. defaultConfig :: Config defaultConfig = Config     { jsPort       = Nothing     , jsAddr       = Nothing+    , jsWindowReloadOnDisconnect = True     , jsCustomHTML = Nothing     , jsStatic     = Nothing     , jsLog        = BS.hPutStrLn stderr     }  {-----------------------------------------------------------------------------+    Server Configuration -- Dynamic+------------------------------------------------------------------------------}+-- | URI type.+--+-- FIXME: Use the correct type from "Network.URI"+type URI = String++-- | MIME type.+type MimeType = String++-- | Representation of a "Foreign.JavaScript" server.+--+-- Can be used for dynamic configuration, e.g. serving additional files.+data Server = Server+    { sFiles :: MVar Filepaths+    , sDirs  :: MVar Filepaths+    }+type Filepaths = (Integer, Map ByteString (FilePath, MimeType))+newFilepaths = (0, Map.empty)++{-----------------------------------------------------------------------------     Communication channel ------------------------------------------------------------------------------} -- | Bidirectional communication channel. data Comm = Comm-    { commIn    :: TQueue JSON.Value-    , commOut   :: TQueue JSON.Value-    , commClose :: IO ()+    { commIn    :: TQueue JSON.Value    -- ^ Read from channel.+    , commOut   :: TQueue JSON.Value    -- ^ Write into channel.+    , commOpen  :: TVar   Bool          -- ^ Indicate whether the channel is still open.+    , commClose :: IO ()                -- ^ Close the channel.     }  writeComm :: Comm -> JSON.Value -> STM ()@@ -84,6 +152,7 @@ data ClientMsg     = Event Coupon JSON.Value     | Result JSON.Value+    | Exception String     | Quit     deriving (Eq, Show) @@ -91,12 +160,10 @@     parseJSON (Object msg) = do         tag <- msg .: "tag"         case (tag :: Text) of-            "Event" ->-                Event  <$> (msg .: "name") <*> (msg .: "arguments")-            "Result" ->-                Result <$> (msg .: "contents")-            "Quit"   ->-                return Quit+            "Event"     -> Event     <$> (msg .: "name") <*> (msg .: "arguments")+            "Result"    -> Result    <$> (msg .: "contents")+            "Exception" -> Exception <$> (msg .: "contents")+            "Quit"      -> return Quit  readClient :: Comm -> STM ClientMsg readClient c = do@@ -137,12 +204,28 @@  However, we have to make sure that the exception is thrown in the thread that constructed the message, not in the thread that-handles the actual communication with the client. That's why we use-the function `Control.DeepSeq.force` to make sure that any exception+handles the actual communication with the client.++That's why we have to use the function+`Control.DeepSeq.deepseq` to make sure that any exception is thrown before handing the message over to another thread. +Since exceptions in pure code do not have a precise ordering relative+to exceptions in IO code, evaluating the pure value+also helps with ensuring that the exception is raised before+any subsequent IO exception; this makes it easier to pinpoint+the root cause for library users.+ -} ++data JavaScriptException = JavaScriptException String deriving Typeable++instance E.Exception JavaScriptException++instance Show JavaScriptException where+    showsPrec _ (JavaScriptException err) = showString $ "JavaScript error: " ++ err+ {-----------------------------------------------------------------------------     Window & Event Loop ------------------------------------------------------------------------------}@@ -155,10 +238,33 @@ quit :: Event quit = ("quit", JSON.Null, Consistent) +-- | Specification of how JavaScript functions should be called.+--+-- The default mode for a new browser window is 'NoBuffering'.+-- Use 'setCallBufferMode' to change the mode at any time.+data CallBufferMode+    = NoBuffering+    -- ^ When 'runFunction' is used to call a JavaScript function,+    -- immediately send a message to the browser window to execute+    -- said function.+    | BufferRun+    -- ^ When 'runFunction' is used to call a JavaScript function,+    -- hold back any message to the server.+    -- All JavaScript functions that are held back in this way+    -- are combined into a single message,+    -- which is finally sent whenever 'callFunction' or+    -- 'flushCallBuffer' are used.+ -- | Representation of a browser window. data Window = Window-    { runEval        :: String -> IO ()+    { getServer      :: Server+    -- ^ Server that tbe browser window communicates with.+    , runEval        :: String -> IO ()     , callEval       :: String -> IO JSON.Value++    , wCallBuffer     :: TVar (String -> String)+    , wCallBufferMode :: TVar CallBufferMode+     , timestamp      :: IO ()     -- ^ Print a timestamp and the time difference to the previous one     -- in the JavaScript console.@@ -174,8 +280,10 @@ newPartialWindow :: IO Window newPartialWindow = do     ptr <- newRemotePtr "" () =<< newVendor+    b1  <- newTVarIO id+    b2  <- newTVarIO BufferRun     let nop = const $ return ()-    Window nop undefined (return ()) nop nop ptr <$> newVendor <*> newVendor+    Window undefined nop undefined b1 b2 (return ()) nop nop ptr <$> newVendor <*> newVendor  -- | For the purpose of controlling garbage collection, -- every 'Window' as an associated 'RemotePtr' that is alive

@@ -49,7 +49,7 @@   case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif #else-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->+mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->   case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif 

@@ -1,21 +1,22 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module Graphics.UI.Threepenny.Core (     -- * Synopsis     -- | Core functionality of the Threepenny GUI library.-    +     -- * Server     -- $server     Config(..), defaultConfig, startGUI,-    +    loadFile, loadDirectory,+     -- * UI monad     -- $ui-    UI, runUI, askWindow, liftIOLater,+    UI, runUI, MonadUI(..), askWindow, liftIOLater,     module Control.Monad.IO.Class,     module Control.Monad.Fix,-    +     -- * Browser Window     Window, title,-    +     -- * DOM elements     -- | Create and manipulate DOM elements.     Element, getWindow, mkElement, mkElementNamespace, delete,@@ -23,43 +24,45 @@         getHead, getBody,         (#+), children, text, html, attr, style, value,     getElementsByTagName, getElementById, getElementsByClassName,-    +     -- * Layout     -- | Combinators for quickly creating layouts.     -- They can be adjusted with CSS later on.     grid, row, column,-    +     -- * Events     -- | For a list of predefined events, see "Graphics.UI.Threepenny.Events".     EventData, domEvent, unsafeFromJSON, disconnect, on, onEvent, onChanges,     module Reactive.Threepenny,-    +     -- * Attributes     -- | For a list of predefined attributes, see "Graphics.UI.Threepenny.Attributes".     (#), (#.),     Attr, WriteAttr, ReadAttr, ReadWriteAttr(..),     set, sink, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,     bimapAttr, fromObjectProperty,-    +     -- * Widgets     Widget(..), element, widget,-    +     -- * JavaScript FFI     -- | Direct interface to JavaScript in the browser window.     debug, timestamp,     ToJS, FFI,     JSFunction, ffi, runFunction, callFunction,+    CallBufferMode(..), setCallBufferMode, flushCallBuffer,     ffiExport,-    +     -- * Internal and oddball functions     fromJQueryProp,-    +     ) where  import Control.Monad          (forM_, forM, void) import Control.Monad.Fix import Control.Monad.IO.Class +import qualified Control.Monad.Catch             as E import qualified Data.Aeson                      as JSON import qualified Foreign.JavaScript              as JS import qualified Graphics.UI.Threepenny.Internal as Core@@ -162,15 +165,13 @@     mapM fromJSObject =<< callFunction (ffi "document.getElementsByTagName(%1)" tag)  -- | Get an element by a particular ID.------ FIXME: Misleading type, throws a JavaScript exception when element not found. getElementById     :: Window              -- ^ Browser window     -> String              -- ^ The ID string.     -> UI (Maybe Element)  -- ^ Element (if any) with given ID.-getElementById _ id = do-    x <- fromJSObject =<< callFunction (ffi "document.getElementById(%1)" id)-    return $ Just x+getElementById _ id =+    E.handle (\(e :: JS.JavaScriptException) -> return Nothing) $+        fmap Just . fromJSObject =<< callFunction (ffi "document.getElementById(%1)" id)  -- | Get a list of elements by particular class. getElementsByClassName@@ -213,7 +214,7 @@ grid    :: [[UI Element]] -> UI Element grid mrows = do         rows0 <- mapM (sequence) mrows-    +         rows  <- forM rows0 $ \row0 -> do             row <- forM row0 $ \entry ->                 wrap "table-cell" [entry]@@ -235,7 +236,7 @@ on f x = void . onEvent (f x)  -- | Register an 'UI' action to be executed whenever the 'Event' happens.--- +-- -- FIXME: Should be unified with 'on'? onEvent :: Event a -> (a -> UI void) -> UI (UI ()) onEvent e h = do@@ -315,7 +316,7 @@     liftIOLater $ do         i <- currentValue bi         runUI window $ set' attr i x-        Reactive.onChange bi  $ \i -> runUI window $ set' attr i x  +        Reactive.onChange bi  $ \i -> runUI window $ set' attr i x     return x  -- | Get attribute value.

@@ -1,12 +1,13 @@ module Graphics.UI.Threepenny.Events (     -- * Synopsis     -- | Events on DOM elements.-    +     -- * Convenience events     valueChange, selectionChange, checkedChange,-    +     -- * Standard DOM events-    click, mousemove, mousedown, mouseup, hover, leave,+    click, contextmenu, mousemove, mousedown, mouseup,+    hover, leave,     focus, blur,     KeyCode, keyup, keydown,     ) where@@ -41,6 +42,10 @@ click :: Element -> Event () click = silence . domEvent "click" +-- | Context menu event.+contextmenu :: Element -> Event (Int,Int)+contextmenu = fmap readCoordinates . domEvent "contextmenu"+ -- | Mouse enters an element. hover :: Element -> Event () hover = silence . domEvent "mouseenter"@@ -61,12 +66,12 @@     where [x,y] = unsafeFromJSON json  -- | Mouse down event.--- The mouse coordinates are relative to the element. +-- The mouse coordinates are relative to the element. mousedown :: Element -> Event (Int,Int) mousedown = fmap readCoordinates . domEvent "mousedown"  -- | Mouse up event.--- The mouse coordinates are relative to the element. +-- The mouse coordinates are relative to the element. mouseup :: Element -> Event (Int,Int) mouseup = fmap readCoordinates . domEvent "mouseup" 

@@ -6,12 +6,14 @@      -- * Documentation     Window, disconnect,-    startGUI,+    startGUI, loadFile, loadDirectory, -    UI, runUI, liftIOLater, askWindow,+    UI, runUI, MonadUI(..), liftIOLater, askWindow,      FFI, FromJS, ToJS, JSFunction, JSObject, ffi,-    runFunction, callFunction, ffiExport, debug, timestamp,+    runFunction, callFunction,+    CallBufferMode(..), setCallBufferMode, flushCallBuffer,+    ffiExport, debug, timestamp,      Element, fromJSObject, getWindow,     mkElementNamespace, mkElement, delete, appendChild, clearChildren,@@ -21,6 +23,7 @@  import           Control.Applicative                   (Applicative) import           Control.Monad+import           Control.Monad.Catch import           Control.Monad.Fix import           Control.Monad.IO.Class import qualified Control.Monad.Trans.RWS.Lazy as Monad@@ -30,9 +33,11 @@ import qualified Foreign.JavaScript      as JS import qualified Foreign.RemotePtr       as Foreign -import qualified Reactive.Threepenny     as E+import qualified Reactive.Threepenny     as RB -import Foreign.JavaScript hiding (runFunction, callFunction, debug, timestamp, Window)+import Foreign.JavaScript hiding+    (runFunction, callFunction, setCallBufferMode, flushCallBuffer+    ,debug, timestamp, Window, loadFile, loadDirectory)  {-----------------------------------------------------------------------------     Custom Window type@@ -40,7 +45,7 @@ -- | The type 'Window' represents a browser window. data Window = Window     { jsWindow    :: JS.Window  -- JavaScript window-    , eDisconnect :: E.Event () -- event that happens when client disconnects+    , eDisconnect :: RB.Event () -- event that happens when client disconnects     , wEvents     :: Foreign.Vendor Events                      -- events associated to 'Element's     , wChildren   :: Foreign.Vendor ()@@ -54,7 +59,7 @@     -> IO () startGUI config init = JS.serve config $ \w -> do     -- set up disconnect event-    (eDisconnect, handleDisconnect) <- E.newEvent+    (eDisconnect, handleDisconnect) <- RB.newEvent     JS.onDisconnect w $ handleDisconnect ()      -- make window@@ -75,13 +80,24 @@ -- -- Note: DOM Elements in a browser window that has been closed -- can no longer be manipulated.-disconnect :: Window -> E.Event ()+disconnect :: Window -> RB.Event () disconnect = eDisconnect +-- | Begin to serve a local file with a given 'MimeType' under a relative URI.+loadFile+    :: String    -- ^ MIME type+    -> FilePath  -- ^ Local path to the file+    -> UI String -- ^ Relative URI under which this file is now accessible+loadFile x y = liftJSWindow $ \w -> JS.loadFile (JS.getServer w) x y++-- | Make a local directory available under a relative URI.+loadDirectory :: FilePath -> UI String+loadDirectory x = liftJSWindow $ \w -> JS.loadDirectory (JS.getServer w) x+ {-----------------------------------------------------------------------------     Elements ------------------------------------------------------------------------------}-type Events = String -> E.Event JSON.Value+type Events = String -> RB.Event JSON.Value  -- Reachability information for children of an 'Element'. -- The children of an element are always reachable from this RemotePtr.@@ -146,7 +162,7 @@             JS.runFunction w $                 ffi "Haskell.bind(%1,%2,%3)" el name handlerPtr -    events <- E.newEventsNamed initializeEvent+    events <- RB.newEventsNamed initializeEvent      -- Create new pointer and add reachability.     Foreign.withRemotePtr el $ \coupon _ -> do@@ -181,7 +197,7 @@         --   Note that the @on@-prefix is not included,         --   the name is @click@ and so on.     -> Element          -- ^ Element where the event is to occur.-    -> E.Event EventData+    -> RB.Event EventData domEvent name el = elEvents el name  -- | Make a new DOM element with a given tag name.@@ -202,6 +218,13 @@         fromJSObject0 el window  -- | Delete the given element.+--+-- This operation removes the element from the browser window DOM+-- and marks it for garbage collection on the Haskell side.+-- The element is unuseable afterwards.+--+-- NOTE: If you wish to temporarily remove an element from the DOM tree,+-- change the 'children' property of its parent element instead. delete :: Element -> UI () delete el = liftJSWindow $ \w -> do     JS.runFunction w $ ffi "$(%1).detach()" el@@ -249,6 +272,13 @@ newtype UI a = UI { unUI :: Monad.RWST Window [IO ()] () IO a }     deriving (Typeable) +class (Monad m) => MonadUI m where+    -- | Lift a computation from the 'UI' monad.+    liftUI :: UI a -> m a++instance MonadUI UI where+    liftUI = id+ liftJSWindow :: (JS.Window -> IO a) -> UI a liftJSWindow f = askWindow >>= liftIO . f . jsWindow @@ -269,6 +299,12 @@ instance MonadFix UI where     mfix f = UI $ mfix (unUI . f) +instance MonadThrow UI where+    throwM = UI . throwM++instance MonadCatch UI where+    catch m f = UI $ catch (unUI m) (unUI . f)+ -- | Execute an 'UI' action in a particular browser window. -- Also runs all scheduled 'IO' actions. runUI :: Window -> UI a -> IO a@@ -291,6 +327,10 @@ -- | Run the given JavaScript function and carry on. Doesn't block. -- -- The client window uses JavaScript's @eval()@ function to run the code.+--+-- NOTE: The JavaScript function need not be executed immediately,+-- it can be buffered and sent to the browser window at a later time.+-- See 'setCallBufferMode' and 'flushCallBuffer' for more. runFunction :: JSFunction () -> UI () runFunction fun = liftJSWindow $ \w -> JS.runFunction w fun @@ -300,10 +340,30 @@ callFunction :: JSFunction a -> UI a callFunction fun = liftJSWindow $ \w -> JS.callFunction w fun +-- | Set the call buffering mode for the browser window.+setCallBufferMode :: CallBufferMode -> UI ()+setCallBufferMode x = liftJSWindow $ \w -> JS.setCallBufferMode w x++-- | Flush the call buffer,+-- i.e. send all outstanding JavaScript to the client in one single message.+flushCallBuffer :: UI ()+flushCallBuffer = liftJSWindow $ \w -> JS.flushCallBuffer w+ -- | Export the given Haskell function so that it can be called -- from JavaScript code. ----- FIXME: At the moment, the function is not garbage collected.+-- NOTE: At the moment, the 'JSObject' representing the exported function+-- will be referenced by the browser 'Window' in which it was created,+-- preventing garbage collection until this browser 'Window' is disconnected.+--+-- This makes it possible to use it as an event handler on the JavaScript side,+-- but it also means that the Haskell runtime has no way to detect+-- early when it is no longer needed.+--+-- In contrast, if you use the function 'domEvent' to register an+-- event handler to an 'Element',+-- then the handler will be garbage collected+-- as soon as the associated 'Element' is garbage collected. ffiExport :: JS.IsHandler a => a -> UI JSObject ffiExport fun = liftJSWindow $ \w -> do     handlerPtr <- JS.exportHandler w fun

@@ -1,5 +1,5 @@ Name:                threepenny-gui-Version:             0.7.0.2+Version:             0.8.0.0 Synopsis:            GUI framework that uses the web browser as a display. Description:     Threepenny-GUI is a GUI framework that uses the web browser as a display.@@ -48,10 +48,12 @@ flag buildExamples     description: Build example executables.     default:     False+    manual:      True  flag network-uri     description: Get Network.URI from the network-uri package     default:     True+    manual:      False  flag rebug     description: The library uses some techniques that are highly@@ -60,6 +62,7 @@                  Bugs in these subsystems are harder to find.                  Activating this flag will expose more of them.     default:     False+    manual:      True  Source-repository head     type:               git@@ -110,6 +113,7 @@                     ,containers             >= 0.4.2 && < 0.6                     ,data-default           >= 0.5.0 && < 0.8                     ,deepseq                >= 1.3.0 && < 1.5+                    ,exceptions             >= 0.6   && < 0.9                     ,filepath               >= 1.3.0 && < 1.5.0                     ,hashable               >= 1.1.0 && < 1.3                     ,safe                   == 0.3.*@@ -162,6 +166,7 @@     else         buildable: False     main-is:           Canvas.hs+    other-modules:     Paths     hs-source-dirs:    samples  Executable threepenny-examples-chat