diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,203 +1,207 @@ -## Changelog for the `threepenny-gui` package - -**0.8.2.1** — Maintenance release - -* Bump dependencies to allow `async` 2.2 -* Fix a compatibility issue with Cabal-2.0 - -**0.8.2.0** — Snapshot release - -* Add `getCookies` function that retrieves the cookies sent with the HTTP request when the browser window connects (to the websocket). [#137][] -* Allow Electron process to be accessed from JavaScript FFI. [#200][] This means that Threepenny is now more useful when used with the [Electron][] framework, see [doc/electron.md](doc/electron.md) for more information on that. -* Bump dependencies to allow `file-embed` 0.0.10.1 - - [#137]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/137 - [#200]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/200 - [electron]: https://electron.atom.io - -**0.8.1.0** — Snapshot release - -* 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][] -* Update bundled jQuery to version 3.2.1. [#186][] - - [customevent]: https://developer.mozilla.org/en-US/docs/Web/API/CustomEvent/CustomEvent - [#163]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/163 - [#181]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/181 - [#185]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/185 - [#186]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/186 - [#191]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/191 - [#192]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/192 - [#196]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/196 - - -**0.8.0.1** — Maintenance release - -* Bump dependencies for compatibility with GHC-8.2.1 -* Bump dependencies to allow `websockets` 0.12 - -**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 - -* 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 - -* 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][] -* 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 -* Adapt to GHC 8.0.1. [#138][] -* Bump dependencies to allow `aeson` 1.0 -* 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 `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 - -* Bump dependencies to allow `base` 4.9 -* Bump dependencies to allow `aeson` 0.11 - -**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. - -* 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. -* Add `` tag to indicate UTF8 encoding in html file. [#116][] - - [#113]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/113 - [#109]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/109 - [#116]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/116 - -**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. - -* Remove unused direct dependencies, in particular -** attoparsec-enumerator -** utf8-string -** MonadCatchIO-transformers -** time - -**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. - -* 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. - -* Possibility to specify IP address to bind the server to. -* FFI now supports callbacks into Haskell. Remove `callDeferredFunction` function. -* `Graphics.UI.Threepenny.Canvas.SVG` for creating SVG elements and attributes. -* 2D graphics API in `Graphics.UI.Threepenny.Canvas` is beginning to grow. -* `Bool` is now correctly marshalled to JavaScript. -* `Text` can now be marshalled to JavaScrtip. - -**0.4.2.0** — Maintenance release. - -* Dependency `bytestring >=0.9.2` is now implemented correctly. -* Allow newer versions of `aeson` dependency. -* Allow newer versions of `network`, `transformers` and `template-haskell` dependencies. -* 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. - -* 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. - -* Fix CSS bug for `grid` function. - -**0.4.0.1** — Maintenance release. - -* Adjust package dependencies. - -**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].) -* First stab at widgets. -* Bump dependencies to allow `websockets` 0.8 - - [#60]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/60 - -**0.3.0.0** — Snapshot release. - -* Browser communication with WebSockets. -* First stab at FRP integration. - -**0.2.0.0** — Snapshot release. - -* First stab at easy JavaScript FFI. - -**0.1.0.0** - -* Initial release. - - +## Changelog for the `threepenny-gui` package + +**0.8.2.2** – Maintenance release + +* Bump dependencies to allow `exceptions` 0.9.0 + +**0.8.2.1** — Maintenance release + +* Bump dependencies to allow `async` 2.2 +* Fix a compatibility issue with Cabal-2.0 + +**0.8.2.0** — Snapshot release + +* Add `getCookies` function that retrieves the cookies sent with the HTTP request when the browser window connects (to the websocket). [#137][] +* Allow Electron process to be accessed from JavaScript FFI. [#200][] This means that Threepenny is now more useful when used with the [Electron][] framework, see [doc/electron.md](doc/electron.md) for more information on that. +* Bump dependencies to allow `file-embed` 0.0.10.1 + + [#137]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/137 + [#200]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/200 + [electron]: https://electron.atom.io + +**0.8.1.0** — Snapshot release + +* 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][] +* Update bundled jQuery to version 3.2.1. [#186][] + + [customevent]: https://developer.mozilla.org/en-US/docs/Web/API/CustomEvent/CustomEvent + [#163]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/163 + [#181]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/181 + [#185]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/185 + [#186]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/186 + [#191]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/191 + [#192]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/192 + [#196]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/196 + + +**0.8.0.1** — Maintenance release + +* Bump dependencies for compatibility with GHC-8.2.1 +* Bump dependencies to allow `websockets` 0.12 + +**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 + +* 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 + +* 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][] +* 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 +* Adapt to GHC 8.0.1. [#138][] +* Bump dependencies to allow `aeson` 1.0 +* 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 `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 + +* Bump dependencies to allow `base` 4.9 +* Bump dependencies to allow `aeson` 0.11 + +**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. + +* 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. +* Add `` tag to indicate UTF8 encoding in html file. [#116][] + + [#113]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/113 + [#109]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/109 + [#116]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/116 + +**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. + +* Remove unused direct dependencies, in particular +** attoparsec-enumerator +** utf8-string +** MonadCatchIO-transformers +** time + +**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. + +* 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. + +* Possibility to specify IP address to bind the server to. +* FFI now supports callbacks into Haskell. Remove `callDeferredFunction` function. +* `Graphics.UI.Threepenny.Canvas.SVG` for creating SVG elements and attributes. +* 2D graphics API in `Graphics.UI.Threepenny.Canvas` is beginning to grow. +* `Bool` is now correctly marshalled to JavaScript. +* `Text` can now be marshalled to JavaScrtip. + +**0.4.2.0** — Maintenance release. + +* Dependency `bytestring >=0.9.2` is now implemented correctly. +* Allow newer versions of `aeson` dependency. +* Allow newer versions of `network`, `transformers` and `template-haskell` dependencies. +* 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. + +* 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. + +* Fix CSS bug for `grid` function. + +**0.4.0.1** — Maintenance release. + +* Adjust package dependencies. + +**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].) +* First stab at widgets. +* Bump dependencies to allow `websockets` 0.8 + + [#60]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/60 + +**0.3.0.0** — Snapshot release. + +* Browser communication with WebSockets. +* First stab at FRP integration. + +**0.2.0.0** — Snapshot release. + +* First stab at easy JavaScript FFI. + +**0.1.0.0** + +* Initial release. + + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,38 +1,38 @@ -The following license ("BSD3") applies to almost all files in this project, -in particular the source code indicated in the `threepenny-gui.cabal` file. -Exceptions are audio sample (*.wav) files, -and files whose content explicitely indicates a different license. - --- - -Copyright (c) 2012-2016, Threepenny-GUI authors (see CONTRIBUTORS) -Copyright (c) 2012, Jeremy Bowers -Copyright (c) 2011-2012, Chris Done -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Heinrich Apfelmus nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license ("BSD3") applies to almost all files in this project, +in particular the source code indicated in the `threepenny-gui.cabal` file. +Exceptions are audio sample (*.wav) files, +and files whose content explicitely indicates a different license. + +-- + +Copyright (c) 2012-2016, Threepenny-GUI authors (see CONTRIBUTORS) +Copyright (c) 2012, Jeremy Bowers +Copyright (c) 2011-2012, Chris Done +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Heinrich Apfelmus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,66 +1,66 @@ -[![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 - -### 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 - -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. - -### 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. You can use it on your local network as well. - -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. - -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 - -### HTML rendering mode - -It might be nice in the case of search engines to merely generate a DOM and render it, so that search engines can read the pages. - -### UI libraries - -[qooxdoo](http://qooxdoo.org/demo) — provides a feature-complete widget set. One could wrap this in a type-safe API from Threepenny and get a complete, stable UI framework for free. Most of the "immediate feedback" like dragging things here, switching tabs there, are taken care of by the framework. All that would be left would be to provide the domain configuration and business/presentation logic. - -There are plenty more like this, but this is the first that springs to -mind that is good. - -# 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, 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. +[![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 + +### 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 + +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. + +### 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. You can use it on your local network as well. + +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. + +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 Haskell to JavaScript with [Haste](https://github.com/valderman/haste-compiler) or [GHCJS](https://github.com/ghcjs/ghcjs). + +# Future ideas + +### HTML rendering mode + +It might be nice in the case of search engines to merely generate a DOM and render it, so that search engines can read the pages. + +### UI libraries + +[qooxdoo](http://qooxdoo.org/demo) — provides a feature-complete widget set. One could wrap this in a type-safe API from Threepenny and get a complete, stable UI framework for free. Most of the "immediate feedback" like dragging things here, switching tabs there, are taken care of by the framework. All that would be left would be to provide the domain configuration and business/presentation logic. + +There are plenty more like this, but this is the first that springs to +mind that is good. + +# 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, 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/js/comm.js b/js/comm.js --- a/js/comm.js +++ b/js/comm.js @@ -1,160 +1,160 @@ -/* ********************************************************************* - Client-server communication - using WebSockets - - The function createWebSocket(receive) creates a client-server - connection. The argument function `receive` is called whenever the client - receives a message. The connection object has a single member `send` - which can be used to send messages to the server. - - In Haskell types: - - createWebSocket :: (JSON -> IO ()) -> IO { send :: JSON -> IO () } - -********************************************************************* */ -Haskell.createWebSocket = function (url0, receive) { - var that = {}; - var optReloadOnDisconnect = false; - var url = 'ws:' + url0.slice(5) + '/websocket/'; - var ws = new WebSocket(url); - - // Close WebSocket when the browser window is closed. - $(window).on('unload', function () { - ws.close(); - }); - - // Send ping message in regular intervals. - // We expect pong messages in return to keep the connection alive. - var ping = function () { - // 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. - ws.onopen = function (e) { - ping(); - ws.onmessage = function (msg) { - // Haskell.log("WebSocket message: %o",msg); - if (msg.data !== "pong") { - receive(JSON.parse(msg.data)); - } - }; - 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); - }; - }; - - // Send a JSON message to the server - 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; -}; - - -/* ********************************************************************* - Client-server communication - using HTTP - - WARNING: The following code is untested legacy code. - It's only there because there may be a chance we want to resurrect it. - -********************************************************************* */ - -/* ********************************************************************* -Threepenny.createHTTP = function (receive) { - var that; - var signal_count = 0; - var sessionToken = {}; - - window.setTimeout(function () { - waitForEvents(); - }); - - // Poll instruction from the server. - var waitForEvents = function () { - console.log("Polling… (%d signals so far)",signal_count); - var data = { token: sessionToken }; - var cmd = sessionToken != null? 'poll' : 'init'; - if (cmd === 'init') { - data.info = window.location.href; - } - var req = $.ajax({ - dataType: 'json', - url : cmd, - data: data, - success: function (events) { - if (sessionToken == null) { - sessionToken = req.getResponseHeader('Set-Token').match(/[0-9]+/)*1; - } - console.log("Running event" +(events.length>1?'s':'') +"…") - if (events.length) { - console.log('Event list:'); - runMultipleEvents(events); - } else { - runEvent(events, signalEvent, function(response){ - maybeReply(response, waitForEvents); - }); - } - }, - error: function(reply) { - console.log("Error, waiting..."); - window.setTimeout(function(){ - waitForEvents(); - },5000); - } - }); - } - - var runMultipleEvents = function (events){ - if(events.length == 0) { - return waitForEvents(); - } - runEvent(events.shift(), signalEvent, function(response){ - maybeReply(response, function(){ - runMultipleEvents(events); - }); - }); - } - - // Send an event to the server. - var signalEvent = function (value) { - signal({ Event: value}, function (){}); - } - - // Send a reply to the server if necessary. - var maybeReply = function (response, continuation) { - if (response != undefined) { signal(response, continuation); } - else { continuation(); } - } - - // Send response back to the server. - var signal = function signal(signal,continuation) { - signal_count++; - console.log('Signal: %s',JSON.stringify(signal)); - $.ajax({ - dataType: 'json', - url:'signal', - data: { token: sessionToken, signal: JSON.stringify(signal) }, - success: function(){ - continuation(); - }, - error: function(reply){ - console.log("Error: %o",reply); - } - }); - } - - return that; -}; -********************************************************************* */ +/* ********************************************************************* + Client-server communication + using WebSockets + + The function createWebSocket(receive) creates a client-server + connection. The argument function `receive` is called whenever the client + receives a message. The connection object has a single member `send` + which can be used to send messages to the server. + + In Haskell types: + + createWebSocket :: (JSON -> IO ()) -> IO { send :: JSON -> IO () } + +********************************************************************* */ +Haskell.createWebSocket = function (url0, receive) { + var that = {}; + var optReloadOnDisconnect = false; + var url = 'ws:' + url0.slice(5) + '/websocket/'; + var ws = new WebSocket(url); + + // Close WebSocket when the browser window is closed. + $(window).on('unload', function () { + ws.close(); + }); + + // Send ping message in regular intervals. + // We expect pong messages in return to keep the connection alive. + var ping = function () { + // 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. + ws.onopen = function (e) { + ping(); + ws.onmessage = function (msg) { + // Haskell.log("WebSocket message: %o",msg); + if (msg.data !== "pong") { + receive(JSON.parse(msg.data)); + } + }; + 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); + }; + }; + + // Send a JSON message to the server + 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; +}; + + +/* ********************************************************************* + Client-server communication + using HTTP + + WARNING: The following code is untested legacy code. + It's only there because there may be a chance we want to resurrect it. + +********************************************************************* */ + +/* ********************************************************************* +Threepenny.createHTTP = function (receive) { + var that; + var signal_count = 0; + var sessionToken = {}; + + window.setTimeout(function () { + waitForEvents(); + }); + + // Poll instruction from the server. + var waitForEvents = function () { + console.log("Polling… (%d signals so far)",signal_count); + var data = { token: sessionToken }; + var cmd = sessionToken != null? 'poll' : 'init'; + if (cmd === 'init') { + data.info = window.location.href; + } + var req = $.ajax({ + dataType: 'json', + url : cmd, + data: data, + success: function (events) { + if (sessionToken == null) { + sessionToken = req.getResponseHeader('Set-Token').match(/[0-9]+/)*1; + } + console.log("Running event" +(events.length>1?'s':'') +"…") + if (events.length) { + console.log('Event list:'); + runMultipleEvents(events); + } else { + runEvent(events, signalEvent, function(response){ + maybeReply(response, waitForEvents); + }); + } + }, + error: function(reply) { + console.log("Error, waiting..."); + window.setTimeout(function(){ + waitForEvents(); + },5000); + } + }); + } + + var runMultipleEvents = function (events){ + if(events.length == 0) { + return waitForEvents(); + } + runEvent(events.shift(), signalEvent, function(response){ + maybeReply(response, function(){ + runMultipleEvents(events); + }); + }); + } + + // Send an event to the server. + var signalEvent = function (value) { + signal({ Event: value}, function (){}); + } + + // Send a reply to the server if necessary. + var maybeReply = function (response, continuation) { + if (response != undefined) { signal(response, continuation); } + else { continuation(); } + } + + // Send response back to the server. + var signal = function signal(signal,continuation) { + signal_count++; + console.log('Signal: %s',JSON.stringify(signal)); + $.ajax({ + dataType: 'json', + url:'signal', + data: { token: sessionToken, signal: JSON.stringify(signal) }, + success: function(){ + continuation(); + }, + error: function(reply){ + console.log("Error: %o",reply); + } + }); + } + + return that; +}; +********************************************************************* */ diff --git a/js/ffi.js b/js/ffi.js --- a/js/ffi.js +++ b/js/ffi.js @@ -1,135 +1,135 @@ -/* ********************************************************************* - Foreign Function Interface (FFI) - JavaScript <-> Haskell - - This module implements everything necessary to call JS functions - from Haskell and vice versa. - - * Listen to server and call JS functions on request. - * Present Haskell functions as objects that can be called from JS. - * StablePtr for JS objects. - -********************************************************************* */ - -// Connect to the Haskell server and initialize the FFI. -// An optional string argument can be used to specify the server URL. -Haskell.initFFI = function () { - var connection; - var url = window.location.origin.toString(); - - if (arguments[0]) { - url = arguments[0]; // take server url from argument - } - - ///////////////////////////////////////////////////////////////////// - // Listen to server and execute JS functions - var reply = function (response) { - if (response !== undefined) { - connection.send(response); - } - }; - - var receive = function (msg) { - Haskell.log("Server message: %o", msg); - - switch (msg.tag) { - - case "RunEval": - try { - eval(msg.contents); - reply(); - } 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": - Haskell.log("Timestamp: %f ms", Haskell.performance.now()); - Haskell.log("Elapsed since last timestamp: %f ms", - Haskell.performance.diff()); - reply(); - break; - } - }; - - // Initialize connection to server. - connection = Haskell.createWebSocket(url, receive); - - ///////////////////////////////////////////////////////////////////// - // Calling Haskell functions - - // An event is a function on the server side that can be called anytime, - // but whose execution will be queued. - Haskell.newEvent = function (name, args) { - var that = function () { - var theargs = []; - if (args) { - theargs = eval(args); - } else { - for (var i=0; i Haskell + + This module implements everything necessary to call JS functions + from Haskell and vice versa. + + * Listen to server and call JS functions on request. + * Present Haskell functions as objects that can be called from JS. + * StablePtr for JS objects. + +********************************************************************* */ + +// Connect to the Haskell server and initialize the FFI. +// An optional string argument can be used to specify the server URL. +Haskell.initFFI = function () { + var connection; + var url = window.location.origin.toString(); + + if (arguments[0]) { + url = arguments[0]; // take server url from argument + } + + ///////////////////////////////////////////////////////////////////// + // Listen to server and execute JS functions + var reply = function (response) { + if (response !== undefined) { + connection.send(response); + } + }; + + var receive = function (msg) { + Haskell.log("Server message: %o", msg); + + switch (msg.tag) { + + case "RunEval": + try { + eval(msg.contents); + reply(); + } 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": + Haskell.log("Timestamp: %f ms", Haskell.performance.now()); + Haskell.log("Elapsed since last timestamp: %f ms", + Haskell.performance.diff()); + reply(); + break; + } + }; + + // Initialize connection to server. + connection = Haskell.createWebSocket(url, receive); + + ///////////////////////////////////////////////////////////////////// + // Calling Haskell functions + + // An event is a function on the server side that can be called anytime, + // but whose execution will be queued. + Haskell.newEvent = function (name, args) { + var that = function () { + var theargs = []; + if (args) { + theargs = eval(args); + } else { + for (var i=0; i - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + diff --git a/js/lib.js b/js/lib.js --- a/js/lib.js +++ b/js/lib.js @@ -1,111 +1,111 @@ -/* ********************************************************************* - Threepenny - JavaScript library - - Additional JavaScript functions that are available - for Threepenny. -********************************************************************* */ -window.jquery_scrollToBottom = function(el){ - $(el).scrollTop(el.scrollHeight); -}; - -Haskell.map = function (fun, array) { - var result = []; - for (i=0; i 1 && (!/Object/.test(Object.prototype.toString.call(value)) || value === null || value === undefined)) { - options = $.extend({}, options); - - if (value === null || value === undefined) { - options.expires = -1; - } - - if (typeof options.expires === 'number') { - var days = options.expires, t = options.expires = new Date(); - t.setDate(t.getDate() + days); - } - - value = String(value); - - return (document.cookie = [ - encodeURIComponent(key), '=', options.raw ? value : encodeURIComponent(value), - options.expires ? '; expires=' + options.expires.toUTCString() : '', // use expires attribute, max-age is not supported by IE - options.path ? '; path=' + options.path : '', - options.domain ? '; domain=' + options.domain : '', - options.secure ? '; secure' : '' - ].join('')); - } - - // key and possibly options given, get cookie... - options = value || {}; - var decode = options.raw ? function(s) { return s; } : decodeURIComponent; - - var pairs = document.cookie.split('; '); - for (var i = 0, pair; pair = pairs[i] && pairs[i].split('='); i++) { - if (decode(pair[0]) === key) return decode(pair[1] || ''); // IE saves cookies with empty string as "c; ", e.g. without "=" as opposed to EOMB, thus pair[1] may be undefined - } - return null; - }; - - $.setSimpleCookie = function(name,value,f) { - $.cookie(name,value,{ - path: '/', - expire: 999 // TODO: - }); - f(); - }; - -})(jQuery); +/** + * jQuery Cookie plugin + * + * Copyright (c) 2010 Klaus Hartl (stilbuero.de) + * Dual licensed under the MIT and GPL licenses: + * http://www.opensource.org/licenses/mit-license.php + * http://www.gnu.org/licenses/gpl.html + * + */ +(function($) { + $.cookie = function(key, value, options) { + + // key and at least value given, set cookie... + if (arguments.length > 1 && (!/Object/.test(Object.prototype.toString.call(value)) || value === null || value === undefined)) { + options = $.extend({}, options); + + if (value === null || value === undefined) { + options.expires = -1; + } + + if (typeof options.expires === 'number') { + var days = options.expires, t = options.expires = new Date(); + t.setDate(t.getDate() + days); + } + + value = String(value); + + return (document.cookie = [ + encodeURIComponent(key), '=', options.raw ? value : encodeURIComponent(value), + options.expires ? '; expires=' + options.expires.toUTCString() : '', // use expires attribute, max-age is not supported by IE + options.path ? '; path=' + options.path : '', + options.domain ? '; domain=' + options.domain : '', + options.secure ? '; secure' : '' + ].join('')); + } + + // key and possibly options given, get cookie... + options = value || {}; + var decode = options.raw ? function(s) { return s; } : decodeURIComponent; + + var pairs = document.cookie.split('; '); + for (var i = 0, pair; pair = pairs[i] && pairs[i].split('='); i++) { + if (decode(pair[0]) === key) return decode(pair[1] || ''); // IE saves cookies with empty string as "c; ", e.g. without "=" as opposed to EOMB, thus pair[1] may be undefined + } + return null; + }; + + $.setSimpleCookie = function(name,value,f) { + $.cookie(name,value,{ + path: '/', + expire: 999 // TODO: + }); + f(); + }; + +})(jQuery); diff --git a/js/lib/jquery.js b/js/lib/jquery.js --- a/js/lib/jquery.js +++ b/js/lib/jquery.js @@ -1,4 +1,4 @@ -/*! jQuery v3.2.1 | (c) JS Foundation and other contributors | jquery.org/license */ -!function(a,b){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=a.document?b(a,!0):function(a){if(!a.document)throw new Error("jQuery requires a window with a document");return b(a)}:b(a)}("undefined"!=typeof window?window:this,function(a,b){"use strict";var c=[],d=a.document,e=Object.getPrototypeOf,f=c.slice,g=c.concat,h=c.push,i=c.indexOf,j={},k=j.toString,l=j.hasOwnProperty,m=l.toString,n=m.call(Object),o={};function p(a,b){b=b||d;var c=b.createElement("script");c.text=a,b.head.appendChild(c).parentNode.removeChild(c)}var q="3.2.1",r=function(a,b){return new r.fn.init(a,b)},s=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g,t=/^-ms-/,u=/-([a-z])/g,v=function(a,b){return b.toUpperCase()};r.fn=r.prototype={jquery:q,constructor:r,length:0,toArray:function(){return f.call(this)},get:function(a){return null==a?f.call(this):a<0?this[a+this.length]:this[a]},pushStack:function(a){var b=r.merge(this.constructor(),a);return b.prevObject=this,b},each:function(a){return r.each(this,a)},map:function(a){return this.pushStack(r.map(this,function(b,c){return a.call(b,c,b)}))},slice:function(){return this.pushStack(f.apply(this,arguments))},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},eq:function(a){var b=this.length,c=+a+(a<0?b:0);return this.pushStack(c>=0&&c0&&b-1 in a)}var x=function(a){var b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u="sizzle"+1*new Date,v=a.document,w=0,x=0,y=ha(),z=ha(),A=ha(),B=function(a,b){return a===b&&(l=!0),0},C={}.hasOwnProperty,D=[],E=D.pop,F=D.push,G=D.push,H=D.slice,I=function(a,b){for(var c=0,d=a.length;c+~]|"+K+")"+K+"*"),S=new RegExp("="+K+"*([^\\]'\"]*?)"+K+"*\\]","g"),T=new RegExp(N),U=new RegExp("^"+L+"$"),V={ID:new RegExp("^#("+L+")"),CLASS:new RegExp("^\\.("+L+")"),TAG:new RegExp("^("+L+"|[*])"),ATTR:new RegExp("^"+M),PSEUDO:new RegExp("^"+N),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+K+"*(even|odd|(([+-]|)(\\d*)n|)"+K+"*(?:([+-]|)"+K+"*(\\d+)|))"+K+"*\\)|)","i"),bool:new RegExp("^(?:"+J+")$","i"),needsContext:new RegExp("^"+K+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+K+"*((?:-\\d)?\\d*)"+K+"*\\)|)(?=[^-]|$)","i")},W=/^(?:input|select|textarea|button)$/i,X=/^h\d$/i,Y=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,$=/[+~]/,_=new RegExp("\\\\([\\da-f]{1,6}"+K+"?|("+K+")|.)","ig"),aa=function(a,b,c){var d="0x"+b-65536;return d!==d||c?b:d<0?String.fromCharCode(d+65536):String.fromCharCode(d>>10|55296,1023&d|56320)},ba=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\0-\x1f\x7f-\uFFFF\w-]/g,ca=function(a,b){return b?"\0"===a?"\ufffd":a.slice(0,-1)+"\\"+a.charCodeAt(a.length-1).toString(16)+" ":"\\"+a},da=function(){m()},ea=ta(function(a){return a.disabled===!0&&("form"in a||"label"in a)},{dir:"parentNode",next:"legend"});try{G.apply(D=H.call(v.childNodes),v.childNodes),D[v.childNodes.length].nodeType}catch(fa){G={apply:D.length?function(a,b){F.apply(a,H.call(b))}:function(a,b){var c=a.length,d=0;while(a[c++]=b[d++]);a.length=c-1}}}function ga(a,b,d,e){var f,h,j,k,l,o,r,s=b&&b.ownerDocument,w=b?b.nodeType:9;if(d=d||[],"string"!=typeof a||!a||1!==w&&9!==w&&11!==w)return d;if(!e&&((b?b.ownerDocument||b:v)!==n&&m(b),b=b||n,p)){if(11!==w&&(l=Z.exec(a)))if(f=l[1]){if(9===w){if(!(j=b.getElementById(f)))return d;if(j.id===f)return d.push(j),d}else if(s&&(j=s.getElementById(f))&&t(b,j)&&j.id===f)return d.push(j),d}else{if(l[2])return G.apply(d,b.getElementsByTagName(a)),d;if((f=l[3])&&c.getElementsByClassName&&b.getElementsByClassName)return G.apply(d,b.getElementsByClassName(f)),d}if(c.qsa&&!A[a+" "]&&(!q||!q.test(a))){if(1!==w)s=b,r=a;else if("object"!==b.nodeName.toLowerCase()){(k=b.getAttribute("id"))?k=k.replace(ba,ca):b.setAttribute("id",k=u),o=g(a),h=o.length;while(h--)o[h]="#"+k+" "+sa(o[h]);r=o.join(","),s=$.test(a)&&qa(b.parentNode)||b}if(r)try{return G.apply(d,s.querySelectorAll(r)),d}catch(x){}finally{k===u&&b.removeAttribute("id")}}}return i(a.replace(P,"$1"),b,d,e)}function ha(){var a=[];function b(c,e){return a.push(c+" ")>d.cacheLength&&delete b[a.shift()],b[c+" "]=e}return b}function ia(a){return a[u]=!0,a}function ja(a){var b=n.createElement("fieldset");try{return!!a(b)}catch(c){return!1}finally{b.parentNode&&b.parentNode.removeChild(b),b=null}}function ka(a,b){var c=a.split("|"),e=c.length;while(e--)d.attrHandle[c[e]]=b}function la(a,b){var c=b&&a,d=c&&1===a.nodeType&&1===b.nodeType&&a.sourceIndex-b.sourceIndex;if(d)return d;if(c)while(c=c.nextSibling)if(c===b)return-1;return a?1:-1}function ma(a){return function(b){var c=b.nodeName.toLowerCase();return"input"===c&&b.type===a}}function na(a){return function(b){var c=b.nodeName.toLowerCase();return("input"===c||"button"===c)&&b.type===a}}function oa(a){return function(b){return"form"in b?b.parentNode&&b.disabled===!1?"label"in b?"label"in b.parentNode?b.parentNode.disabled===a:b.disabled===a:b.isDisabled===a||b.isDisabled!==!a&&ea(b)===a:b.disabled===a:"label"in b&&b.disabled===a}}function pa(a){return ia(function(b){return b=+b,ia(function(c,d){var e,f=a([],c.length,b),g=f.length;while(g--)c[e=f[g]]&&(c[e]=!(d[e]=c[e]))})})}function qa(a){return a&&"undefined"!=typeof a.getElementsByTagName&&a}c=ga.support={},f=ga.isXML=function(a){var b=a&&(a.ownerDocument||a).documentElement;return!!b&&"HTML"!==b.nodeName},m=ga.setDocument=function(a){var b,e,g=a?a.ownerDocument||a:v;return g!==n&&9===g.nodeType&&g.documentElement?(n=g,o=n.documentElement,p=!f(n),v!==n&&(e=n.defaultView)&&e.top!==e&&(e.addEventListener?e.addEventListener("unload",da,!1):e.attachEvent&&e.attachEvent("onunload",da)),c.attributes=ja(function(a){return a.className="i",!a.getAttribute("className")}),c.getElementsByTagName=ja(function(a){return a.appendChild(n.createComment("")),!a.getElementsByTagName("*").length}),c.getElementsByClassName=Y.test(n.getElementsByClassName),c.getById=ja(function(a){return o.appendChild(a).id=u,!n.getElementsByName||!n.getElementsByName(u).length}),c.getById?(d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){return a.getAttribute("id")===b}},d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c=b.getElementById(a);return c?[c]:[]}}):(d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){var c="undefined"!=typeof a.getAttributeNode&&a.getAttributeNode("id");return c&&c.value===b}},d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c,d,e,f=b.getElementById(a);if(f){if(c=f.getAttributeNode("id"),c&&c.value===a)return[f];e=b.getElementsByName(a),d=0;while(f=e[d++])if(c=f.getAttributeNode("id"),c&&c.value===a)return[f]}return[]}}),d.find.TAG=c.getElementsByTagName?function(a,b){return"undefined"!=typeof b.getElementsByTagName?b.getElementsByTagName(a):c.qsa?b.querySelectorAll(a):void 0}:function(a,b){var c,d=[],e=0,f=b.getElementsByTagName(a);if("*"===a){while(c=f[e++])1===c.nodeType&&d.push(c);return d}return f},d.find.CLASS=c.getElementsByClassName&&function(a,b){if("undefined"!=typeof b.getElementsByClassName&&p)return b.getElementsByClassName(a)},r=[],q=[],(c.qsa=Y.test(n.querySelectorAll))&&(ja(function(a){o.appendChild(a).innerHTML="",a.querySelectorAll("[msallowcapture^='']").length&&q.push("[*^$]="+K+"*(?:''|\"\")"),a.querySelectorAll("[selected]").length||q.push("\\["+K+"*(?:value|"+J+")"),a.querySelectorAll("[id~="+u+"-]").length||q.push("~="),a.querySelectorAll(":checked").length||q.push(":checked"),a.querySelectorAll("a#"+u+"+*").length||q.push(".#.+[+~]")}),ja(function(a){a.innerHTML="";var b=n.createElement("input");b.setAttribute("type","hidden"),a.appendChild(b).setAttribute("name","D"),a.querySelectorAll("[name=d]").length&&q.push("name"+K+"*[*^$|!~]?="),2!==a.querySelectorAll(":enabled").length&&q.push(":enabled",":disabled"),o.appendChild(a).disabled=!0,2!==a.querySelectorAll(":disabled").length&&q.push(":enabled",":disabled"),a.querySelectorAll("*,:x"),q.push(",.*:")})),(c.matchesSelector=Y.test(s=o.matches||o.webkitMatchesSelector||o.mozMatchesSelector||o.oMatchesSelector||o.msMatchesSelector))&&ja(function(a){c.disconnectedMatch=s.call(a,"*"),s.call(a,"[s!='']:x"),r.push("!=",N)}),q=q.length&&new RegExp(q.join("|")),r=r.length&&new RegExp(r.join("|")),b=Y.test(o.compareDocumentPosition),t=b||Y.test(o.contains)?function(a,b){var c=9===a.nodeType?a.documentElement:a,d=b&&b.parentNode;return a===d||!(!d||1!==d.nodeType||!(c.contains?c.contains(d):a.compareDocumentPosition&&16&a.compareDocumentPosition(d)))}:function(a,b){if(b)while(b=b.parentNode)if(b===a)return!0;return!1},B=b?function(a,b){if(a===b)return l=!0,0;var d=!a.compareDocumentPosition-!b.compareDocumentPosition;return d?d:(d=(a.ownerDocument||a)===(b.ownerDocument||b)?a.compareDocumentPosition(b):1,1&d||!c.sortDetached&&b.compareDocumentPosition(a)===d?a===n||a.ownerDocument===v&&t(v,a)?-1:b===n||b.ownerDocument===v&&t(v,b)?1:k?I(k,a)-I(k,b):0:4&d?-1:1)}:function(a,b){if(a===b)return l=!0,0;var c,d=0,e=a.parentNode,f=b.parentNode,g=[a],h=[b];if(!e||!f)return a===n?-1:b===n?1:e?-1:f?1:k?I(k,a)-I(k,b):0;if(e===f)return la(a,b);c=a;while(c=c.parentNode)g.unshift(c);c=b;while(c=c.parentNode)h.unshift(c);while(g[d]===h[d])d++;return d?la(g[d],h[d]):g[d]===v?-1:h[d]===v?1:0},n):n},ga.matches=function(a,b){return ga(a,null,null,b)},ga.matchesSelector=function(a,b){if((a.ownerDocument||a)!==n&&m(a),b=b.replace(S,"='$1']"),c.matchesSelector&&p&&!A[b+" "]&&(!r||!r.test(b))&&(!q||!q.test(b)))try{var d=s.call(a,b);if(d||c.disconnectedMatch||a.document&&11!==a.document.nodeType)return d}catch(e){}return ga(b,n,null,[a]).length>0},ga.contains=function(a,b){return(a.ownerDocument||a)!==n&&m(a),t(a,b)},ga.attr=function(a,b){(a.ownerDocument||a)!==n&&m(a);var e=d.attrHandle[b.toLowerCase()],f=e&&C.call(d.attrHandle,b.toLowerCase())?e(a,b,!p):void 0;return void 0!==f?f:c.attributes||!p?a.getAttribute(b):(f=a.getAttributeNode(b))&&f.specified?f.value:null},ga.escape=function(a){return(a+"").replace(ba,ca)},ga.error=function(a){throw new Error("Syntax error, unrecognized expression: "+a)},ga.uniqueSort=function(a){var b,d=[],e=0,f=0;if(l=!c.detectDuplicates,k=!c.sortStable&&a.slice(0),a.sort(B),l){while(b=a[f++])b===a[f]&&(e=d.push(f));while(e--)a.splice(d[e],1)}return k=null,a},e=ga.getText=function(a){var b,c="",d=0,f=a.nodeType;if(f){if(1===f||9===f||11===f){if("string"==typeof a.textContent)return a.textContent;for(a=a.firstChild;a;a=a.nextSibling)c+=e(a)}else if(3===f||4===f)return a.nodeValue}else while(b=a[d++])c+=e(b);return c},d=ga.selectors={cacheLength:50,createPseudo:ia,match:V,attrHandle:{},find:{},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(a){return a[1]=a[1].replace(_,aa),a[3]=(a[3]||a[4]||a[5]||"").replace(_,aa),"~="===a[2]&&(a[3]=" "+a[3]+" "),a.slice(0,4)},CHILD:function(a){return a[1]=a[1].toLowerCase(),"nth"===a[1].slice(0,3)?(a[3]||ga.error(a[0]),a[4]=+(a[4]?a[5]+(a[6]||1):2*("even"===a[3]||"odd"===a[3])),a[5]=+(a[7]+a[8]||"odd"===a[3])):a[3]&&ga.error(a[0]),a},PSEUDO:function(a){var b,c=!a[6]&&a[2];return V.CHILD.test(a[0])?null:(a[3]?a[2]=a[4]||a[5]||"":c&&T.test(c)&&(b=g(c,!0))&&(b=c.indexOf(")",c.length-b)-c.length)&&(a[0]=a[0].slice(0,b),a[2]=c.slice(0,b)),a.slice(0,3))}},filter:{TAG:function(a){var b=a.replace(_,aa).toLowerCase();return"*"===a?function(){return!0}:function(a){return a.nodeName&&a.nodeName.toLowerCase()===b}},CLASS:function(a){var b=y[a+" "];return b||(b=new RegExp("(^|"+K+")"+a+"("+K+"|$)"))&&y(a,function(a){return b.test("string"==typeof a.className&&a.className||"undefined"!=typeof a.getAttribute&&a.getAttribute("class")||"")})},ATTR:function(a,b,c){return function(d){var e=ga.attr(d,a);return null==e?"!="===b:!b||(e+="","="===b?e===c:"!="===b?e!==c:"^="===b?c&&0===e.indexOf(c):"*="===b?c&&e.indexOf(c)>-1:"$="===b?c&&e.slice(-c.length)===c:"~="===b?(" "+e.replace(O," ")+" ").indexOf(c)>-1:"|="===b&&(e===c||e.slice(0,c.length+1)===c+"-"))}},CHILD:function(a,b,c,d,e){var f="nth"!==a.slice(0,3),g="last"!==a.slice(-4),h="of-type"===b;return 1===d&&0===e?function(a){return!!a.parentNode}:function(b,c,i){var j,k,l,m,n,o,p=f!==g?"nextSibling":"previousSibling",q=b.parentNode,r=h&&b.nodeName.toLowerCase(),s=!i&&!h,t=!1;if(q){if(f){while(p){m=b;while(m=m[p])if(h?m.nodeName.toLowerCase()===r:1===m.nodeType)return!1;o=p="only"===a&&!o&&"nextSibling"}return!0}if(o=[g?q.firstChild:q.lastChild],g&&s){m=q,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n&&j[2],m=n&&q.childNodes[n];while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if(1===m.nodeType&&++t&&m===b){k[a]=[w,n,t];break}}else if(s&&(m=b,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n),t===!1)while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if((h?m.nodeName.toLowerCase()===r:1===m.nodeType)&&++t&&(s&&(l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),k[a]=[w,t]),m===b))break;return t-=e,t===d||t%d===0&&t/d>=0}}},PSEUDO:function(a,b){var c,e=d.pseudos[a]||d.setFilters[a.toLowerCase()]||ga.error("unsupported pseudo: "+a);return e[u]?e(b):e.length>1?(c=[a,a,"",b],d.setFilters.hasOwnProperty(a.toLowerCase())?ia(function(a,c){var d,f=e(a,b),g=f.length;while(g--)d=I(a,f[g]),a[d]=!(c[d]=f[g])}):function(a){return e(a,0,c)}):e}},pseudos:{not:ia(function(a){var b=[],c=[],d=h(a.replace(P,"$1"));return d[u]?ia(function(a,b,c,e){var f,g=d(a,null,e,[]),h=a.length;while(h--)(f=g[h])&&(a[h]=!(b[h]=f))}):function(a,e,f){return b[0]=a,d(b,null,f,c),b[0]=null,!c.pop()}}),has:ia(function(a){return function(b){return ga(a,b).length>0}}),contains:ia(function(a){return a=a.replace(_,aa),function(b){return(b.textContent||b.innerText||e(b)).indexOf(a)>-1}}),lang:ia(function(a){return U.test(a||"")||ga.error("unsupported lang: "+a),a=a.replace(_,aa).toLowerCase(),function(b){var c;do if(c=p?b.lang:b.getAttribute("xml:lang")||b.getAttribute("lang"))return c=c.toLowerCase(),c===a||0===c.indexOf(a+"-");while((b=b.parentNode)&&1===b.nodeType);return!1}}),target:function(b){var c=a.location&&a.location.hash;return c&&c.slice(1)===b.id},root:function(a){return a===o},focus:function(a){return a===n.activeElement&&(!n.hasFocus||n.hasFocus())&&!!(a.type||a.href||~a.tabIndex)},enabled:oa(!1),disabled:oa(!0),checked:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&!!a.checked||"option"===b&&!!a.selected},selected:function(a){return a.parentNode&&a.parentNode.selectedIndex,a.selected===!0},empty:function(a){for(a=a.firstChild;a;a=a.nextSibling)if(a.nodeType<6)return!1;return!0},parent:function(a){return!d.pseudos.empty(a)},header:function(a){return X.test(a.nodeName)},input:function(a){return W.test(a.nodeName)},button:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&"button"===a.type||"button"===b},text:function(a){var b;return"input"===a.nodeName.toLowerCase()&&"text"===a.type&&(null==(b=a.getAttribute("type"))||"text"===b.toLowerCase())},first:pa(function(){return[0]}),last:pa(function(a,b){return[b-1]}),eq:pa(function(a,b,c){return[c<0?c+b:c]}),even:pa(function(a,b){for(var c=0;c=0;)a.push(d);return a}),gt:pa(function(a,b,c){for(var d=c<0?c+b:c;++d1?function(b,c,d){var e=a.length;while(e--)if(!a[e](b,c,d))return!1;return!0}:a[0]}function va(a,b,c){for(var d=0,e=b.length;d-1&&(f[j]=!(g[j]=l))}}else r=wa(r===g?r.splice(o,r.length):r),e?e(null,g,r,i):G.apply(g,r)})}function ya(a){for(var b,c,e,f=a.length,g=d.relative[a[0].type],h=g||d.relative[" "],i=g?1:0,k=ta(function(a){return a===b},h,!0),l=ta(function(a){return I(b,a)>-1},h,!0),m=[function(a,c,d){var e=!g&&(d||c!==j)||((b=c).nodeType?k(a,c,d):l(a,c,d));return b=null,e}];i1&&ua(m),i>1&&sa(a.slice(0,i-1).concat({value:" "===a[i-2].type?"*":""})).replace(P,"$1"),c,i0,e=a.length>0,f=function(f,g,h,i,k){var l,o,q,r=0,s="0",t=f&&[],u=[],v=j,x=f||e&&d.find.TAG("*",k),y=w+=null==v?1:Math.random()||.1,z=x.length;for(k&&(j=g===n||g||k);s!==z&&null!=(l=x[s]);s++){if(e&&l){o=0,g||l.ownerDocument===n||(m(l),h=!p);while(q=a[o++])if(q(l,g||n,h)){i.push(l);break}k&&(w=y)}c&&((l=!q&&l)&&r--,f&&t.push(l))}if(r+=s,c&&s!==r){o=0;while(q=b[o++])q(t,u,g,h);if(f){if(r>0)while(s--)t[s]||u[s]||(u[s]=E.call(i));u=wa(u)}G.apply(i,u),k&&!f&&u.length>0&&r+b.length>1&&ga.uniqueSort(i)}return k&&(w=y,j=v),t};return c?ia(f):f}return h=ga.compile=function(a,b){var c,d=[],e=[],f=A[a+" "];if(!f){b||(b=g(a)),c=b.length;while(c--)f=ya(b[c]),f[u]?d.push(f):e.push(f);f=A(a,za(e,d)),f.selector=a}return f},i=ga.select=function(a,b,c,e){var f,i,j,k,l,m="function"==typeof a&&a,n=!e&&g(a=m.selector||a);if(c=c||[],1===n.length){if(i=n[0]=n[0].slice(0),i.length>2&&"ID"===(j=i[0]).type&&9===b.nodeType&&p&&d.relative[i[1].type]){if(b=(d.find.ID(j.matches[0].replace(_,aa),b)||[])[0],!b)return c;m&&(b=b.parentNode),a=a.slice(i.shift().value.length)}f=V.needsContext.test(a)?0:i.length;while(f--){if(j=i[f],d.relative[k=j.type])break;if((l=d.find[k])&&(e=l(j.matches[0].replace(_,aa),$.test(i[0].type)&&qa(b.parentNode)||b))){if(i.splice(f,1),a=e.length&&sa(i),!a)return G.apply(c,e),c;break}}}return(m||h(a,n))(e,b,!p,c,!b||$.test(a)&&qa(b.parentNode)||b),c},c.sortStable=u.split("").sort(B).join("")===u,c.detectDuplicates=!!l,m(),c.sortDetached=ja(function(a){return 1&a.compareDocumentPosition(n.createElement("fieldset"))}),ja(function(a){return a.innerHTML="","#"===a.firstChild.getAttribute("href")})||ka("type|href|height|width",function(a,b,c){if(!c)return a.getAttribute(b,"type"===b.toLowerCase()?1:2)}),c.attributes&&ja(function(a){return a.innerHTML="",a.firstChild.setAttribute("value",""),""===a.firstChild.getAttribute("value")})||ka("value",function(a,b,c){if(!c&&"input"===a.nodeName.toLowerCase())return a.defaultValue}),ja(function(a){return null==a.getAttribute("disabled")})||ka(J,function(a,b,c){var d;if(!c)return a[b]===!0?b.toLowerCase():(d=a.getAttributeNode(b))&&d.specified?d.value:null}),ga}(a);r.find=x,r.expr=x.selectors,r.expr[":"]=r.expr.pseudos,r.uniqueSort=r.unique=x.uniqueSort,r.text=x.getText,r.isXMLDoc=x.isXML,r.contains=x.contains,r.escapeSelector=x.escape;var y=function(a,b,c){var d=[],e=void 0!==c;while((a=a[b])&&9!==a.nodeType)if(1===a.nodeType){if(e&&r(a).is(c))break;d.push(a)}return d},z=function(a,b){for(var c=[];a;a=a.nextSibling)1===a.nodeType&&a!==b&&c.push(a);return c},A=r.expr.match.needsContext;function B(a,b){return a.nodeName&&a.nodeName.toLowerCase()===b.toLowerCase()}var C=/^<([a-z][^\/\0>:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i,D=/^.[^:#\[\.,]*$/;function E(a,b,c){return r.isFunction(b)?r.grep(a,function(a,d){return!!b.call(a,d,a)!==c}):b.nodeType?r.grep(a,function(a){return a===b!==c}):"string"!=typeof b?r.grep(a,function(a){return i.call(b,a)>-1!==c}):D.test(b)?r.filter(b,a,c):(b=r.filter(b,a),r.grep(a,function(a){return i.call(b,a)>-1!==c&&1===a.nodeType}))}r.filter=function(a,b,c){var d=b[0];return c&&(a=":not("+a+")"),1===b.length&&1===d.nodeType?r.find.matchesSelector(d,a)?[d]:[]:r.find.matches(a,r.grep(b,function(a){return 1===a.nodeType}))},r.fn.extend({find:function(a){var b,c,d=this.length,e=this;if("string"!=typeof a)return this.pushStack(r(a).filter(function(){for(b=0;b1?r.uniqueSort(c):c},filter:function(a){return this.pushStack(E(this,a||[],!1))},not:function(a){return this.pushStack(E(this,a||[],!0))},is:function(a){return!!E(this,"string"==typeof a&&A.test(a)?r(a):a||[],!1).length}});var F,G=/^(?:\s*(<[\w\W]+>)[^>]*|#([\w-]+))$/,H=r.fn.init=function(a,b,c){var e,f;if(!a)return this;if(c=c||F,"string"==typeof a){if(e="<"===a[0]&&">"===a[a.length-1]&&a.length>=3?[null,a,null]:G.exec(a),!e||!e[1]&&b)return!b||b.jquery?(b||c).find(a):this.constructor(b).find(a);if(e[1]){if(b=b instanceof r?b[0]:b,r.merge(this,r.parseHTML(e[1],b&&b.nodeType?b.ownerDocument||b:d,!0)),C.test(e[1])&&r.isPlainObject(b))for(e in b)r.isFunction(this[e])?this[e](b[e]):this.attr(e,b[e]);return this}return f=d.getElementById(e[2]),f&&(this[0]=f,this.length=1),this}return a.nodeType?(this[0]=a,this.length=1,this):r.isFunction(a)?void 0!==c.ready?c.ready(a):a(r):r.makeArray(a,this)};H.prototype=r.fn,F=r(d);var I=/^(?:parents|prev(?:Until|All))/,J={children:!0,contents:!0,next:!0,prev:!0};r.fn.extend({has:function(a){var b=r(a,this),c=b.length;return this.filter(function(){for(var a=0;a-1:1===c.nodeType&&r.find.matchesSelector(c,a))){f.push(c);break}return this.pushStack(f.length>1?r.uniqueSort(f):f)},index:function(a){return a?"string"==typeof a?i.call(r(a),this[0]):i.call(this,a.jquery?a[0]:a):this[0]&&this[0].parentNode?this.first().prevAll().length:-1},add:function(a,b){return this.pushStack(r.uniqueSort(r.merge(this.get(),r(a,b))))},addBack:function(a){return this.add(null==a?this.prevObject:this.prevObject.filter(a))}});function K(a,b){while((a=a[b])&&1!==a.nodeType);return a}r.each({parent:function(a){var b=a.parentNode;return b&&11!==b.nodeType?b:null},parents:function(a){return y(a,"parentNode")},parentsUntil:function(a,b,c){return y(a,"parentNode",c)},next:function(a){return K(a,"nextSibling")},prev:function(a){return K(a,"previousSibling")},nextAll:function(a){return y(a,"nextSibling")},prevAll:function(a){return y(a,"previousSibling")},nextUntil:function(a,b,c){return y(a,"nextSibling",c)},prevUntil:function(a,b,c){return y(a,"previousSibling",c)},siblings:function(a){return z((a.parentNode||{}).firstChild,a)},children:function(a){return z(a.firstChild)},contents:function(a){return B(a,"iframe")?a.contentDocument:(B(a,"template")&&(a=a.content||a),r.merge([],a.childNodes))}},function(a,b){r.fn[a]=function(c,d){var e=r.map(this,b,c);return"Until"!==a.slice(-5)&&(d=c),d&&"string"==typeof d&&(e=r.filter(d,e)),this.length>1&&(J[a]||r.uniqueSort(e),I.test(a)&&e.reverse()),this.pushStack(e)}});var L=/[^\x20\t\r\n\f]+/g;function M(a){var b={};return r.each(a.match(L)||[],function(a,c){b[c]=!0}),b}r.Callbacks=function(a){a="string"==typeof a?M(a):r.extend({},a);var b,c,d,e,f=[],g=[],h=-1,i=function(){for(e=e||a.once,d=b=!0;g.length;h=-1){c=g.shift();while(++h-1)f.splice(c,1),c<=h&&h--}),this},has:function(a){return a?r.inArray(a,f)>-1:f.length>0},empty:function(){return f&&(f=[]),this},disable:function(){return e=g=[],f=c="",this},disabled:function(){return!f},lock:function(){return e=g=[],c||b||(f=c=""),this},locked:function(){return!!e},fireWith:function(a,c){return e||(c=c||[],c=[a,c.slice?c.slice():c],g.push(c),b||i()),this},fire:function(){return j.fireWith(this,arguments),this},fired:function(){return!!d}};return j};function N(a){return a}function O(a){throw a}function P(a,b,c,d){var e;try{a&&r.isFunction(e=a.promise)?e.call(a).done(b).fail(c):a&&r.isFunction(e=a.then)?e.call(a,b,c):b.apply(void 0,[a].slice(d))}catch(a){c.apply(void 0,[a])}}r.extend({Deferred:function(b){var c=[["notify","progress",r.Callbacks("memory"),r.Callbacks("memory"),2],["resolve","done",r.Callbacks("once memory"),r.Callbacks("once memory"),0,"resolved"],["reject","fail",r.Callbacks("once memory"),r.Callbacks("once memory"),1,"rejected"]],d="pending",e={state:function(){return d},always:function(){return f.done(arguments).fail(arguments),this},"catch":function(a){return e.then(null,a)},pipe:function(){var a=arguments;return r.Deferred(function(b){r.each(c,function(c,d){var e=r.isFunction(a[d[4]])&&a[d[4]];f[d[1]](function(){var a=e&&e.apply(this,arguments);a&&r.isFunction(a.promise)?a.promise().progress(b.notify).done(b.resolve).fail(b.reject):b[d[0]+"With"](this,e?[a]:arguments)})}),a=null}).promise()},then:function(b,d,e){var f=0;function g(b,c,d,e){return function(){var h=this,i=arguments,j=function(){var a,j;if(!(b=f&&(d!==O&&(h=void 0,i=[a]),c.rejectWith(h,i))}};b?k():(r.Deferred.getStackHook&&(k.stackTrace=r.Deferred.getStackHook()),a.setTimeout(k))}}return r.Deferred(function(a){c[0][3].add(g(0,a,r.isFunction(e)?e:N,a.notifyWith)),c[1][3].add(g(0,a,r.isFunction(b)?b:N)),c[2][3].add(g(0,a,r.isFunction(d)?d:O))}).promise()},promise:function(a){return null!=a?r.extend(a,e):e}},f={};return r.each(c,function(a,b){var g=b[2],h=b[5];e[b[1]]=g.add,h&&g.add(function(){d=h},c[3-a][2].disable,c[0][2].lock),g.add(b[3].fire),f[b[0]]=function(){return f[b[0]+"With"](this===f?void 0:this,arguments),this},f[b[0]+"With"]=g.fireWith}),e.promise(f),b&&b.call(f,f),f},when:function(a){var b=arguments.length,c=b,d=Array(c),e=f.call(arguments),g=r.Deferred(),h=function(a){return function(c){d[a]=this,e[a]=arguments.length>1?f.call(arguments):c,--b||g.resolveWith(d,e)}};if(b<=1&&(P(a,g.done(h(c)).resolve,g.reject,!b),"pending"===g.state()||r.isFunction(e[c]&&e[c].then)))return g.then();while(c--)P(e[c],h(c),g.reject);return g.promise()}});var Q=/^(Eval|Internal|Range|Reference|Syntax|Type|URI)Error$/;r.Deferred.exceptionHook=function(b,c){a.console&&a.console.warn&&b&&Q.test(b.name)&&a.console.warn("jQuery.Deferred exception: "+b.message,b.stack,c)},r.readyException=function(b){a.setTimeout(function(){throw b})};var R=r.Deferred();r.fn.ready=function(a){return R.then(a)["catch"](function(a){r.readyException(a)}),this},r.extend({isReady:!1,readyWait:1,ready:function(a){(a===!0?--r.readyWait:r.isReady)||(r.isReady=!0,a!==!0&&--r.readyWait>0||R.resolveWith(d,[r]))}}),r.ready.then=R.then;function S(){d.removeEventListener("DOMContentLoaded",S), -a.removeEventListener("load",S),r.ready()}"complete"===d.readyState||"loading"!==d.readyState&&!d.documentElement.doScroll?a.setTimeout(r.ready):(d.addEventListener("DOMContentLoaded",S),a.addEventListener("load",S));var T=function(a,b,c,d,e,f,g){var h=0,i=a.length,j=null==c;if("object"===r.type(c)){e=!0;for(h in c)T(a,b,h,c[h],!0,f,g)}else if(void 0!==d&&(e=!0,r.isFunction(d)||(g=!0),j&&(g?(b.call(a,d),b=null):(j=b,b=function(a,b,c){return j.call(r(a),c)})),b))for(;h1,null,!0)},removeData:function(a){return this.each(function(){X.remove(this,a)})}}),r.extend({queue:function(a,b,c){var d;if(a)return b=(b||"fx")+"queue",d=W.get(a,b),c&&(!d||Array.isArray(c)?d=W.access(a,b,r.makeArray(c)):d.push(c)),d||[]},dequeue:function(a,b){b=b||"fx";var c=r.queue(a,b),d=c.length,e=c.shift(),f=r._queueHooks(a,b),g=function(){r.dequeue(a,b)};"inprogress"===e&&(e=c.shift(),d--),e&&("fx"===b&&c.unshift("inprogress"),delete f.stop,e.call(a,g,f)),!d&&f&&f.empty.fire()},_queueHooks:function(a,b){var c=b+"queueHooks";return W.get(a,c)||W.access(a,c,{empty:r.Callbacks("once memory").add(function(){W.remove(a,[b+"queue",c])})})}}),r.fn.extend({queue:function(a,b){var c=2;return"string"!=typeof a&&(b=a,a="fx",c--),arguments.length\x20\t\r\n\f]+)/i,la=/^$|\/(?:java|ecma)script/i,ma={option:[1,""],thead:[1,"","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};ma.optgroup=ma.option,ma.tbody=ma.tfoot=ma.colgroup=ma.caption=ma.thead,ma.th=ma.td;function na(a,b){var c;return c="undefined"!=typeof a.getElementsByTagName?a.getElementsByTagName(b||"*"):"undefined"!=typeof a.querySelectorAll?a.querySelectorAll(b||"*"):[],void 0===b||b&&B(a,b)?r.merge([a],c):c}function oa(a,b){for(var c=0,d=a.length;c-1)e&&e.push(f);else if(j=r.contains(f.ownerDocument,f),g=na(l.appendChild(f),"script"),j&&oa(g),c){k=0;while(f=g[k++])la.test(f.type||"")&&c.push(f)}return l}!function(){var a=d.createDocumentFragment(),b=a.appendChild(d.createElement("div")),c=d.createElement("input");c.setAttribute("type","radio"),c.setAttribute("checked","checked"),c.setAttribute("name","t"),b.appendChild(c),o.checkClone=b.cloneNode(!0).cloneNode(!0).lastChild.checked,b.innerHTML="",o.noCloneChecked=!!b.cloneNode(!0).lastChild.defaultValue}();var ra=d.documentElement,sa=/^key/,ta=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,ua=/^([^.]*)(?:\.(.+)|)/;function va(){return!0}function wa(){return!1}function xa(){try{return d.activeElement}catch(a){}}function ya(a,b,c,d,e,f){var g,h;if("object"==typeof b){"string"!=typeof c&&(d=d||c,c=void 0);for(h in b)ya(a,h,c,d,b[h],f);return a}if(null==d&&null==e?(e=c,d=c=void 0):null==e&&("string"==typeof c?(e=d,d=void 0):(e=d,d=c,c=void 0)),e===!1)e=wa;else if(!e)return a;return 1===f&&(g=e,e=function(a){return r().off(a),g.apply(this,arguments)},e.guid=g.guid||(g.guid=r.guid++)),a.each(function(){r.event.add(this,b,e,d,c)})}r.event={global:{},add:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=W.get(a);if(q){c.handler&&(f=c,c=f.handler,e=f.selector),e&&r.find.matchesSelector(ra,e),c.guid||(c.guid=r.guid++),(i=q.events)||(i=q.events={}),(g=q.handle)||(g=q.handle=function(b){return"undefined"!=typeof r&&r.event.triggered!==b.type?r.event.dispatch.apply(a,arguments):void 0}),b=(b||"").match(L)||[""],j=b.length;while(j--)h=ua.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n&&(l=r.event.special[n]||{},n=(e?l.delegateType:l.bindType)||n,l=r.event.special[n]||{},k=r.extend({type:n,origType:p,data:d,handler:c,guid:c.guid,selector:e,needsContext:e&&r.expr.match.needsContext.test(e),namespace:o.join(".")},f),(m=i[n])||(m=i[n]=[],m.delegateCount=0,l.setup&&l.setup.call(a,d,o,g)!==!1||a.addEventListener&&a.addEventListener(n,g)),l.add&&(l.add.call(a,k),k.handler.guid||(k.handler.guid=c.guid)),e?m.splice(m.delegateCount++,0,k):m.push(k),r.event.global[n]=!0)}},remove:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=W.hasData(a)&&W.get(a);if(q&&(i=q.events)){b=(b||"").match(L)||[""],j=b.length;while(j--)if(h=ua.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n){l=r.event.special[n]||{},n=(d?l.delegateType:l.bindType)||n,m=i[n]||[],h=h[2]&&new RegExp("(^|\\.)"+o.join("\\.(?:.*\\.|)")+"(\\.|$)"),g=f=m.length;while(f--)k=m[f],!e&&p!==k.origType||c&&c.guid!==k.guid||h&&!h.test(k.namespace)||d&&d!==k.selector&&("**"!==d||!k.selector)||(m.splice(f,1),k.selector&&m.delegateCount--,l.remove&&l.remove.call(a,k));g&&!m.length&&(l.teardown&&l.teardown.call(a,o,q.handle)!==!1||r.removeEvent(a,n,q.handle),delete i[n])}else for(n in i)r.event.remove(a,n+b[j],c,d,!0);r.isEmptyObject(i)&&W.remove(a,"handle events")}},dispatch:function(a){var b=r.event.fix(a),c,d,e,f,g,h,i=new Array(arguments.length),j=(W.get(this,"events")||{})[b.type]||[],k=r.event.special[b.type]||{};for(i[0]=b,c=1;c=1))for(;j!==this;j=j.parentNode||this)if(1===j.nodeType&&("click"!==a.type||j.disabled!==!0)){for(f=[],g={},c=0;c-1:r.find(e,this,null,[j]).length),g[e]&&f.push(d);f.length&&h.push({elem:j,handlers:f})}return j=this,i\x20\t\r\n\f]*)[^>]*)\/>/gi,Aa=/\s*$/g;function Ea(a,b){return B(a,"table")&&B(11!==b.nodeType?b:b.firstChild,"tr")?r(">tbody",a)[0]||a:a}function Fa(a){return a.type=(null!==a.getAttribute("type"))+"/"+a.type,a}function Ga(a){var b=Ca.exec(a.type);return b?a.type=b[1]:a.removeAttribute("type"),a}function Ha(a,b){var c,d,e,f,g,h,i,j;if(1===b.nodeType){if(W.hasData(a)&&(f=W.access(a),g=W.set(b,f),j=f.events)){delete g.handle,g.events={};for(e in j)for(c=0,d=j[e].length;c1&&"string"==typeof q&&!o.checkClone&&Ba.test(q))return a.each(function(e){var f=a.eq(e);s&&(b[0]=q.call(this,e,f.html())),Ja(f,b,c,d)});if(m&&(e=qa(b,a[0].ownerDocument,!1,a,d),f=e.firstChild,1===e.childNodes.length&&(e=f),f||d)){for(h=r.map(na(e,"script"),Fa),i=h.length;l")},clone:function(a,b,c){var d,e,f,g,h=a.cloneNode(!0),i=r.contains(a.ownerDocument,a);if(!(o.noCloneChecked||1!==a.nodeType&&11!==a.nodeType||r.isXMLDoc(a)))for(g=na(h),f=na(a),d=0,e=f.length;d0&&oa(g,!i&&na(a,"script")),h},cleanData:function(a){for(var b,c,d,e=r.event.special,f=0;void 0!==(c=a[f]);f++)if(U(c)){if(b=c[W.expando]){if(b.events)for(d in b.events)e[d]?r.event.remove(c,d):r.removeEvent(c,d,b.handle);c[W.expando]=void 0}c[X.expando]&&(c[X.expando]=void 0)}}}),r.fn.extend({detach:function(a){return Ka(this,a,!0)},remove:function(a){return Ka(this,a)},text:function(a){return T(this,function(a){return void 0===a?r.text(this):this.empty().each(function(){1!==this.nodeType&&11!==this.nodeType&&9!==this.nodeType||(this.textContent=a)})},null,a,arguments.length)},append:function(){return Ja(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ea(this,a);b.appendChild(a)}})},prepend:function(){return Ja(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ea(this,a);b.insertBefore(a,b.firstChild)}})},before:function(){return Ja(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this)})},after:function(){return Ja(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this.nextSibling)})},empty:function(){for(var a,b=0;null!=(a=this[b]);b++)1===a.nodeType&&(r.cleanData(na(a,!1)),a.textContent="");return this},clone:function(a,b){return a=null!=a&&a,b=null==b?a:b,this.map(function(){return r.clone(this,a,b)})},html:function(a){return T(this,function(a){var b=this[0]||{},c=0,d=this.length;if(void 0===a&&1===b.nodeType)return b.innerHTML;if("string"==typeof a&&!Aa.test(a)&&!ma[(ka.exec(a)||["",""])[1].toLowerCase()]){a=r.htmlPrefilter(a);try{for(;c1)}});function _a(a,b,c,d,e){return new _a.prototype.init(a,b,c,d,e)}r.Tween=_a,_a.prototype={constructor:_a,init:function(a,b,c,d,e,f){this.elem=a,this.prop=c,this.easing=e||r.easing._default,this.options=b,this.start=this.now=this.cur(),this.end=d,this.unit=f||(r.cssNumber[c]?"":"px")},cur:function(){var a=_a.propHooks[this.prop];return a&&a.get?a.get(this):_a.propHooks._default.get(this)},run:function(a){var b,c=_a.propHooks[this.prop];return this.options.duration?this.pos=b=r.easing[this.easing](a,this.options.duration*a,0,1,this.options.duration):this.pos=b=a,this.now=(this.end-this.start)*b+this.start,this.options.step&&this.options.step.call(this.elem,this.now,this),c&&c.set?c.set(this):_a.propHooks._default.set(this),this}},_a.prototype.init.prototype=_a.prototype,_a.propHooks={_default:{get:function(a){var b;return 1!==a.elem.nodeType||null!=a.elem[a.prop]&&null==a.elem.style[a.prop]?a.elem[a.prop]:(b=r.css(a.elem,a.prop,""),b&&"auto"!==b?b:0)},set:function(a){r.fx.step[a.prop]?r.fx.step[a.prop](a):1!==a.elem.nodeType||null==a.elem.style[r.cssProps[a.prop]]&&!r.cssHooks[a.prop]?a.elem[a.prop]=a.now:r.style(a.elem,a.prop,a.now+a.unit)}}},_a.propHooks.scrollTop=_a.propHooks.scrollLeft={set:function(a){a.elem.nodeType&&a.elem.parentNode&&(a.elem[a.prop]=a.now)}},r.easing={linear:function(a){return a},swing:function(a){return.5-Math.cos(a*Math.PI)/2},_default:"swing"},r.fx=_a.prototype.init,r.fx.step={};var ab,bb,cb=/^(?:toggle|show|hide)$/,db=/queueHooks$/;function eb(){bb&&(d.hidden===!1&&a.requestAnimationFrame?a.requestAnimationFrame(eb):a.setTimeout(eb,r.fx.interval),r.fx.tick())}function fb(){return a.setTimeout(function(){ab=void 0}),ab=r.now()}function gb(a,b){var c,d=0,e={height:a};for(b=b?1:0;d<4;d+=2-b)c=ca[d],e["margin"+c]=e["padding"+c]=a;return b&&(e.opacity=e.width=a),e}function hb(a,b,c){for(var d,e=(kb.tweeners[b]||[]).concat(kb.tweeners["*"]),f=0,g=e.length;f1)},removeAttr:function(a){return this.each(function(){r.removeAttr(this,a)})}}),r.extend({attr:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return"undefined"==typeof a.getAttribute?r.prop(a,b,c):(1===f&&r.isXMLDoc(a)||(e=r.attrHooks[b.toLowerCase()]||(r.expr.match.bool.test(b)?lb:void 0)),void 0!==c?null===c?void r.removeAttr(a,b):e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:(a.setAttribute(b,c+""),c):e&&"get"in e&&null!==(d=e.get(a,b))?d:(d=r.find.attr(a,b), -null==d?void 0:d))},attrHooks:{type:{set:function(a,b){if(!o.radioValue&&"radio"===b&&B(a,"input")){var c=a.value;return a.setAttribute("type",b),c&&(a.value=c),b}}}},removeAttr:function(a,b){var c,d=0,e=b&&b.match(L);if(e&&1===a.nodeType)while(c=e[d++])a.removeAttribute(c)}}),lb={set:function(a,b,c){return b===!1?r.removeAttr(a,c):a.setAttribute(c,c),c}},r.each(r.expr.match.bool.source.match(/\w+/g),function(a,b){var c=mb[b]||r.find.attr;mb[b]=function(a,b,d){var e,f,g=b.toLowerCase();return d||(f=mb[g],mb[g]=e,e=null!=c(a,b,d)?g:null,mb[g]=f),e}});var nb=/^(?:input|select|textarea|button)$/i,ob=/^(?:a|area)$/i;r.fn.extend({prop:function(a,b){return T(this,r.prop,a,b,arguments.length>1)},removeProp:function(a){return this.each(function(){delete this[r.propFix[a]||a]})}}),r.extend({prop:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return 1===f&&r.isXMLDoc(a)||(b=r.propFix[b]||b,e=r.propHooks[b]),void 0!==c?e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:a[b]=c:e&&"get"in e&&null!==(d=e.get(a,b))?d:a[b]},propHooks:{tabIndex:{get:function(a){var b=r.find.attr(a,"tabindex");return b?parseInt(b,10):nb.test(a.nodeName)||ob.test(a.nodeName)&&a.href?0:-1}}},propFix:{"for":"htmlFor","class":"className"}}),o.optSelected||(r.propHooks.selected={get:function(a){var b=a.parentNode;return b&&b.parentNode&&b.parentNode.selectedIndex,null},set:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}}),r.each(["tabIndex","readOnly","maxLength","cellSpacing","cellPadding","rowSpan","colSpan","useMap","frameBorder","contentEditable"],function(){r.propFix[this.toLowerCase()]=this});function pb(a){var b=a.match(L)||[];return b.join(" ")}function qb(a){return a.getAttribute&&a.getAttribute("class")||""}r.fn.extend({addClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).addClass(a.call(this,b,qb(this)))});if("string"==typeof a&&a){b=a.match(L)||[];while(c=this[i++])if(e=qb(c),d=1===c.nodeType&&" "+pb(e)+" "){g=0;while(f=b[g++])d.indexOf(" "+f+" ")<0&&(d+=f+" ");h=pb(d),e!==h&&c.setAttribute("class",h)}}return this},removeClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).removeClass(a.call(this,b,qb(this)))});if(!arguments.length)return this.attr("class","");if("string"==typeof a&&a){b=a.match(L)||[];while(c=this[i++])if(e=qb(c),d=1===c.nodeType&&" "+pb(e)+" "){g=0;while(f=b[g++])while(d.indexOf(" "+f+" ")>-1)d=d.replace(" "+f+" "," ");h=pb(d),e!==h&&c.setAttribute("class",h)}}return this},toggleClass:function(a,b){var c=typeof a;return"boolean"==typeof b&&"string"===c?b?this.addClass(a):this.removeClass(a):r.isFunction(a)?this.each(function(c){r(this).toggleClass(a.call(this,c,qb(this),b),b)}):this.each(function(){var b,d,e,f;if("string"===c){d=0,e=r(this),f=a.match(L)||[];while(b=f[d++])e.hasClass(b)?e.removeClass(b):e.addClass(b)}else void 0!==a&&"boolean"!==c||(b=qb(this),b&&W.set(this,"__className__",b),this.setAttribute&&this.setAttribute("class",b||a===!1?"":W.get(this,"__className__")||""))})},hasClass:function(a){var b,c,d=0;b=" "+a+" ";while(c=this[d++])if(1===c.nodeType&&(" "+pb(qb(c))+" ").indexOf(b)>-1)return!0;return!1}});var rb=/\r/g;r.fn.extend({val:function(a){var b,c,d,e=this[0];{if(arguments.length)return d=r.isFunction(a),this.each(function(c){var e;1===this.nodeType&&(e=d?a.call(this,c,r(this).val()):a,null==e?e="":"number"==typeof e?e+="":Array.isArray(e)&&(e=r.map(e,function(a){return null==a?"":a+""})),b=r.valHooks[this.type]||r.valHooks[this.nodeName.toLowerCase()],b&&"set"in b&&void 0!==b.set(this,e,"value")||(this.value=e))});if(e)return b=r.valHooks[e.type]||r.valHooks[e.nodeName.toLowerCase()],b&&"get"in b&&void 0!==(c=b.get(e,"value"))?c:(c=e.value,"string"==typeof c?c.replace(rb,""):null==c?"":c)}}}),r.extend({valHooks:{option:{get:function(a){var b=r.find.attr(a,"value");return null!=b?b:pb(r.text(a))}},select:{get:function(a){var b,c,d,e=a.options,f=a.selectedIndex,g="select-one"===a.type,h=g?null:[],i=g?f+1:e.length;for(d=f<0?i:g?f:0;d-1)&&(c=!0);return c||(a.selectedIndex=-1),f}}}}),r.each(["radio","checkbox"],function(){r.valHooks[this]={set:function(a,b){if(Array.isArray(b))return a.checked=r.inArray(r(a).val(),b)>-1}},o.checkOn||(r.valHooks[this].get=function(a){return null===a.getAttribute("value")?"on":a.value})});var sb=/^(?:focusinfocus|focusoutblur)$/;r.extend(r.event,{trigger:function(b,c,e,f){var g,h,i,j,k,m,n,o=[e||d],p=l.call(b,"type")?b.type:b,q=l.call(b,"namespace")?b.namespace.split("."):[];if(h=i=e=e||d,3!==e.nodeType&&8!==e.nodeType&&!sb.test(p+r.event.triggered)&&(p.indexOf(".")>-1&&(q=p.split("."),p=q.shift(),q.sort()),k=p.indexOf(":")<0&&"on"+p,b=b[r.expando]?b:new r.Event(p,"object"==typeof b&&b),b.isTrigger=f?2:3,b.namespace=q.join("."),b.rnamespace=b.namespace?new RegExp("(^|\\.)"+q.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,b.result=void 0,b.target||(b.target=e),c=null==c?[b]:r.makeArray(c,[b]),n=r.event.special[p]||{},f||!n.trigger||n.trigger.apply(e,c)!==!1)){if(!f&&!n.noBubble&&!r.isWindow(e)){for(j=n.delegateType||p,sb.test(j+p)||(h=h.parentNode);h;h=h.parentNode)o.push(h),i=h;i===(e.ownerDocument||d)&&o.push(i.defaultView||i.parentWindow||a)}g=0;while((h=o[g++])&&!b.isPropagationStopped())b.type=g>1?j:n.bindType||p,m=(W.get(h,"events")||{})[b.type]&&W.get(h,"handle"),m&&m.apply(h,c),m=k&&h[k],m&&m.apply&&U(h)&&(b.result=m.apply(h,c),b.result===!1&&b.preventDefault());return b.type=p,f||b.isDefaultPrevented()||n._default&&n._default.apply(o.pop(),c)!==!1||!U(e)||k&&r.isFunction(e[p])&&!r.isWindow(e)&&(i=e[k],i&&(e[k]=null),r.event.triggered=p,e[p](),r.event.triggered=void 0,i&&(e[k]=i)),b.result}},simulate:function(a,b,c){var d=r.extend(new r.Event,c,{type:a,isSimulated:!0});r.event.trigger(d,null,b)}}),r.fn.extend({trigger:function(a,b){return this.each(function(){r.event.trigger(a,b,this)})},triggerHandler:function(a,b){var c=this[0];if(c)return r.event.trigger(a,b,c,!0)}}),r.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(a,b){r.fn[b]=function(a,c){return arguments.length>0?this.on(b,null,a,c):this.trigger(b)}}),r.fn.extend({hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}}),o.focusin="onfocusin"in a,o.focusin||r.each({focus:"focusin",blur:"focusout"},function(a,b){var c=function(a){r.event.simulate(b,a.target,r.event.fix(a))};r.event.special[b]={setup:function(){var d=this.ownerDocument||this,e=W.access(d,b);e||d.addEventListener(a,c,!0),W.access(d,b,(e||0)+1)},teardown:function(){var d=this.ownerDocument||this,e=W.access(d,b)-1;e?W.access(d,b,e):(d.removeEventListener(a,c,!0),W.remove(d,b))}}});var tb=a.location,ub=r.now(),vb=/\?/;r.parseXML=function(b){var c;if(!b||"string"!=typeof b)return null;try{c=(new a.DOMParser).parseFromString(b,"text/xml")}catch(d){c=void 0}return c&&!c.getElementsByTagName("parsererror").length||r.error("Invalid XML: "+b),c};var wb=/\[\]$/,xb=/\r?\n/g,yb=/^(?:submit|button|image|reset|file)$/i,zb=/^(?:input|select|textarea|keygen)/i;function Ab(a,b,c,d){var e;if(Array.isArray(b))r.each(b,function(b,e){c||wb.test(a)?d(a,e):Ab(a+"["+("object"==typeof e&&null!=e?b:"")+"]",e,c,d)});else if(c||"object"!==r.type(b))d(a,b);else for(e in b)Ab(a+"["+e+"]",b[e],c,d)}r.param=function(a,b){var c,d=[],e=function(a,b){var c=r.isFunction(b)?b():b;d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(null==c?"":c)};if(Array.isArray(a)||a.jquery&&!r.isPlainObject(a))r.each(a,function(){e(this.name,this.value)});else for(c in a)Ab(c,a[c],b,e);return d.join("&")},r.fn.extend({serialize:function(){return r.param(this.serializeArray())},serializeArray:function(){return this.map(function(){var a=r.prop(this,"elements");return a?r.makeArray(a):this}).filter(function(){var a=this.type;return this.name&&!r(this).is(":disabled")&&zb.test(this.nodeName)&&!yb.test(a)&&(this.checked||!ja.test(a))}).map(function(a,b){var c=r(this).val();return null==c?null:Array.isArray(c)?r.map(c,function(a){return{name:b.name,value:a.replace(xb,"\r\n")}}):{name:b.name,value:c.replace(xb,"\r\n")}}).get()}});var Bb=/%20/g,Cb=/#.*$/,Db=/([?&])_=[^&]*/,Eb=/^(.*?):[ \t]*([^\r\n]*)$/gm,Fb=/^(?:about|app|app-storage|.+-extension|file|res|widget):$/,Gb=/^(?:GET|HEAD)$/,Hb=/^\/\//,Ib={},Jb={},Kb="*/".concat("*"),Lb=d.createElement("a");Lb.href=tb.href;function Mb(a){return function(b,c){"string"!=typeof b&&(c=b,b="*");var d,e=0,f=b.toLowerCase().match(L)||[];if(r.isFunction(c))while(d=f[e++])"+"===d[0]?(d=d.slice(1)||"*",(a[d]=a[d]||[]).unshift(c)):(a[d]=a[d]||[]).push(c)}}function Nb(a,b,c,d){var e={},f=a===Jb;function g(h){var i;return e[h]=!0,r.each(a[h]||[],function(a,h){var j=h(b,c,d);return"string"!=typeof j||f||e[j]?f?!(i=j):void 0:(b.dataTypes.unshift(j),g(j),!1)}),i}return g(b.dataTypes[0])||!e["*"]&&g("*")}function Ob(a,b){var c,d,e=r.ajaxSettings.flatOptions||{};for(c in b)void 0!==b[c]&&((e[c]?a:d||(d={}))[c]=b[c]);return d&&r.extend(!0,a,d),a}function Pb(a,b,c){var d,e,f,g,h=a.contents,i=a.dataTypes;while("*"===i[0])i.shift(),void 0===d&&(d=a.mimeType||b.getResponseHeader("Content-Type"));if(d)for(e in h)if(h[e]&&h[e].test(d)){i.unshift(e);break}if(i[0]in c)f=i[0];else{for(e in c){if(!i[0]||a.converters[e+" "+i[0]]){f=e;break}g||(g=e)}f=f||g}if(f)return f!==i[0]&&i.unshift(f),c[f]}function Qb(a,b,c,d){var e,f,g,h,i,j={},k=a.dataTypes.slice();if(k[1])for(g in a.converters)j[g.toLowerCase()]=a.converters[g];f=k.shift();while(f)if(a.responseFields[f]&&(c[a.responseFields[f]]=b),!i&&d&&a.dataFilter&&(b=a.dataFilter(b,a.dataType)),i=f,f=k.shift())if("*"===f)f=i;else if("*"!==i&&i!==f){if(g=j[i+" "+f]||j["* "+f],!g)for(e in j)if(h=e.split(" "),h[1]===f&&(g=j[i+" "+h[0]]||j["* "+h[0]])){g===!0?g=j[e]:j[e]!==!0&&(f=h[0],k.unshift(h[1]));break}if(g!==!0)if(g&&a["throws"])b=g(b);else try{b=g(b)}catch(l){return{state:"parsererror",error:g?l:"No conversion from "+i+" to "+f}}}return{state:"success",data:b}}r.extend({active:0,lastModified:{},etag:{},ajaxSettings:{url:tb.href,type:"GET",isLocal:Fb.test(tb.protocol),global:!0,processData:!0,async:!0,contentType:"application/x-www-form-urlencoded; charset=UTF-8",accepts:{"*":Kb,text:"text/plain",html:"text/html",xml:"application/xml, text/xml",json:"application/json, text/javascript"},contents:{xml:/\bxml\b/,html:/\bhtml/,json:/\bjson\b/},responseFields:{xml:"responseXML",text:"responseText",json:"responseJSON"},converters:{"* text":String,"text html":!0,"text json":JSON.parse,"text xml":r.parseXML},flatOptions:{url:!0,context:!0}},ajaxSetup:function(a,b){return b?Ob(Ob(a,r.ajaxSettings),b):Ob(r.ajaxSettings,a)},ajaxPrefilter:Mb(Ib),ajaxTransport:Mb(Jb),ajax:function(b,c){"object"==typeof b&&(c=b,b=void 0),c=c||{};var e,f,g,h,i,j,k,l,m,n,o=r.ajaxSetup({},c),p=o.context||o,q=o.context&&(p.nodeType||p.jquery)?r(p):r.event,s=r.Deferred(),t=r.Callbacks("once memory"),u=o.statusCode||{},v={},w={},x="canceled",y={readyState:0,getResponseHeader:function(a){var b;if(k){if(!h){h={};while(b=Eb.exec(g))h[b[1].toLowerCase()]=b[2]}b=h[a.toLowerCase()]}return null==b?null:b},getAllResponseHeaders:function(){return k?g:null},setRequestHeader:function(a,b){return null==k&&(a=w[a.toLowerCase()]=w[a.toLowerCase()]||a,v[a]=b),this},overrideMimeType:function(a){return null==k&&(o.mimeType=a),this},statusCode:function(a){var b;if(a)if(k)y.always(a[y.status]);else for(b in a)u[b]=[u[b],a[b]];return this},abort:function(a){var b=a||x;return e&&e.abort(b),A(0,b),this}};if(s.promise(y),o.url=((b||o.url||tb.href)+"").replace(Hb,tb.protocol+"//"),o.type=c.method||c.type||o.method||o.type,o.dataTypes=(o.dataType||"*").toLowerCase().match(L)||[""],null==o.crossDomain){j=d.createElement("a");try{j.href=o.url,j.href=j.href,o.crossDomain=Lb.protocol+"//"+Lb.host!=j.protocol+"//"+j.host}catch(z){o.crossDomain=!0}}if(o.data&&o.processData&&"string"!=typeof o.data&&(o.data=r.param(o.data,o.traditional)),Nb(Ib,o,c,y),k)return y;l=r.event&&o.global,l&&0===r.active++&&r.event.trigger("ajaxStart"),o.type=o.type.toUpperCase(),o.hasContent=!Gb.test(o.type),f=o.url.replace(Cb,""),o.hasContent?o.data&&o.processData&&0===(o.contentType||"").indexOf("application/x-www-form-urlencoded")&&(o.data=o.data.replace(Bb,"+")):(n=o.url.slice(f.length),o.data&&(f+=(vb.test(f)?"&":"?")+o.data,delete o.data),o.cache===!1&&(f=f.replace(Db,"$1"),n=(vb.test(f)?"&":"?")+"_="+ub++ +n),o.url=f+n),o.ifModified&&(r.lastModified[f]&&y.setRequestHeader("If-Modified-Since",r.lastModified[f]),r.etag[f]&&y.setRequestHeader("If-None-Match",r.etag[f])),(o.data&&o.hasContent&&o.contentType!==!1||c.contentType)&&y.setRequestHeader("Content-Type",o.contentType),y.setRequestHeader("Accept",o.dataTypes[0]&&o.accepts[o.dataTypes[0]]?o.accepts[o.dataTypes[0]]+("*"!==o.dataTypes[0]?", "+Kb+"; q=0.01":""):o.accepts["*"]);for(m in o.headers)y.setRequestHeader(m,o.headers[m]);if(o.beforeSend&&(o.beforeSend.call(p,y,o)===!1||k))return y.abort();if(x="abort",t.add(o.complete),y.done(o.success),y.fail(o.error),e=Nb(Jb,o,c,y)){if(y.readyState=1,l&&q.trigger("ajaxSend",[y,o]),k)return y;o.async&&o.timeout>0&&(i=a.setTimeout(function(){y.abort("timeout")},o.timeout));try{k=!1,e.send(v,A)}catch(z){if(k)throw z;A(-1,z)}}else A(-1,"No Transport");function A(b,c,d,h){var j,m,n,v,w,x=c;k||(k=!0,i&&a.clearTimeout(i),e=void 0,g=h||"",y.readyState=b>0?4:0,j=b>=200&&b<300||304===b,d&&(v=Pb(o,y,d)),v=Qb(o,v,y,j),j?(o.ifModified&&(w=y.getResponseHeader("Last-Modified"),w&&(r.lastModified[f]=w),w=y.getResponseHeader("etag"),w&&(r.etag[f]=w)),204===b||"HEAD"===o.type?x="nocontent":304===b?x="notmodified":(x=v.state,m=v.data,n=v.error,j=!n)):(n=x,!b&&x||(x="error",b<0&&(b=0))),y.status=b,y.statusText=(c||x)+"",j?s.resolveWith(p,[m,x,y]):s.rejectWith(p,[y,x,n]),y.statusCode(u),u=void 0,l&&q.trigger(j?"ajaxSuccess":"ajaxError",[y,o,j?m:n]),t.fireWith(p,[y,x]),l&&(q.trigger("ajaxComplete",[y,o]),--r.active||r.event.trigger("ajaxStop")))}return y},getJSON:function(a,b,c){return r.get(a,b,c,"json")},getScript:function(a,b){return r.get(a,void 0,b,"script")}}),r.each(["get","post"],function(a,b){r[b]=function(a,c,d,e){return r.isFunction(c)&&(e=e||d,d=c,c=void 0),r.ajax(r.extend({url:a,type:b,dataType:e,data:c,success:d},r.isPlainObject(a)&&a))}}),r._evalUrl=function(a){return r.ajax({url:a,type:"GET",dataType:"script",cache:!0,async:!1,global:!1,"throws":!0})},r.fn.extend({wrapAll:function(a){var b;return this[0]&&(r.isFunction(a)&&(a=a.call(this[0])),b=r(a,this[0].ownerDocument).eq(0).clone(!0),this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstElementChild)a=a.firstElementChild;return a}).append(this)),this},wrapInner:function(a){return r.isFunction(a)?this.each(function(b){r(this).wrapInner(a.call(this,b))}):this.each(function(){var b=r(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){var b=r.isFunction(a);return this.each(function(c){r(this).wrapAll(b?a.call(this,c):a)})},unwrap:function(a){return this.parent(a).not("body").each(function(){r(this).replaceWith(this.childNodes)}),this}}),r.expr.pseudos.hidden=function(a){return!r.expr.pseudos.visible(a)},r.expr.pseudos.visible=function(a){return!!(a.offsetWidth||a.offsetHeight||a.getClientRects().length)},r.ajaxSettings.xhr=function(){try{return new a.XMLHttpRequest}catch(b){}};var Rb={0:200,1223:204},Sb=r.ajaxSettings.xhr();o.cors=!!Sb&&"withCredentials"in Sb,o.ajax=Sb=!!Sb,r.ajaxTransport(function(b){var c,d;if(o.cors||Sb&&!b.crossDomain)return{send:function(e,f){var g,h=b.xhr();if(h.open(b.type,b.url,b.async,b.username,b.password),b.xhrFields)for(g in b.xhrFields)h[g]=b.xhrFields[g];b.mimeType&&h.overrideMimeType&&h.overrideMimeType(b.mimeType),b.crossDomain||e["X-Requested-With"]||(e["X-Requested-With"]="XMLHttpRequest");for(g in e)h.setRequestHeader(g,e[g]);c=function(a){return function(){c&&(c=d=h.onload=h.onerror=h.onabort=h.onreadystatechange=null,"abort"===a?h.abort():"error"===a?"number"!=typeof h.status?f(0,"error"):f(h.status,h.statusText):f(Rb[h.status]||h.status,h.statusText,"text"!==(h.responseType||"text")||"string"!=typeof h.responseText?{binary:h.response}:{text:h.responseText},h.getAllResponseHeaders()))}},h.onload=c(),d=h.onerror=c("error"),void 0!==h.onabort?h.onabort=d:h.onreadystatechange=function(){4===h.readyState&&a.setTimeout(function(){c&&d()})},c=c("abort");try{h.send(b.hasContent&&b.data||null)}catch(i){if(c)throw i}},abort:function(){c&&c()}}}),r.ajaxPrefilter(function(a){a.crossDomain&&(a.contents.script=!1)}),r.ajaxSetup({accepts:{script:"text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"},contents:{script:/\b(?:java|ecma)script\b/},converters:{"text script":function(a){return r.globalEval(a),a}}}),r.ajaxPrefilter("script",function(a){void 0===a.cache&&(a.cache=!1),a.crossDomain&&(a.type="GET")}),r.ajaxTransport("script",function(a){if(a.crossDomain){var b,c;return{send:function(e,f){b=r(" - - - - - - + + + Chat + + + + + + + + + + diff --git a/samples/static/css/DragNDropExample.css b/samples/static/css/DragNDropExample.css --- a/samples/static/css/DragNDropExample.css +++ b/samples/static/css/DragNDropExample.css @@ -1,18 +1,18 @@ -.box-drag { - position: absolute; - top : 20px; - border: 1px solid gray; - width : 90px; - height: 2ex; - text-align: center; - padding: 1ex; -} - -.box-drop { - position: absolute; - top : 100px; - width : 100px; - height: 2.2ex; - text-align: center; - padding: 1ex; -} +.box-drag { + position: absolute; + top : 20px; + border: 1px solid gray; + width : 90px; + height: 2ex; + text-align: center; + padding: 1ex; +} + +.box-drop { + position: absolute; + top : 100px; + width : 100px; + height: 2.2ex; + text-align: center; + padding: 1ex; +} diff --git a/samples/static/css/buttons.css b/samples/static/css/buttons.css --- a/samples/static/css/buttons.css +++ b/samples/static/css/buttons.css @@ -1,52 +1,52 @@ -body { - background: #333; - color: #ccc; - font-family: ubuntu, sans-serif; - font-size: 14px; - background: url(stripes-bg.png); - padding-top: 1em; - text-shadow: #000 3px 1px 3px; -} -.wrap { - width: 40em; - margin: auto; -} -.buttons-list { - color: #aaa; -} -.button { - cursor: pointer; - color: #acc2a1; - text-decoration: underline; -} -a { - color: #acc2a1; -} -button, input { - border: 0; - color: #ccc; - padding: 0.3em; - border-radius:0.3em; - box-shadow: #191919 2px 1px 2px; -} -input { - background: #292929; - width: 2em; -} -button:focus,input:focus { - background: #222; -} -button { - background: #444; -} -h1 { - font-size: 4em; - margin: 0; - padding-bottom: 0.2em; -} -h2 { - margin-top: 1.3em; - padding-bottom: 0em; - margin-bottom:0; -} +body { + background: #333; + color: #ccc; + font-family: ubuntu, sans-serif; + font-size: 14px; + background: url(stripes-bg.png); + padding-top: 1em; + text-shadow: #000 3px 1px 3px; +} +.wrap { + width: 40em; + margin: auto; +} +.buttons-list { + color: #aaa; +} +.button { + cursor: pointer; + color: #acc2a1; + text-decoration: underline; +} +a { + color: #acc2a1; +} +button, input { + border: 0; + color: #ccc; + padding: 0.3em; + border-radius:0.3em; + box-shadow: #191919 2px 1px 2px; +} +input { + background: #292929; + width: 2em; +} +button:focus,input:focus { + background: #222; +} +button { + background: #444; +} +h1 { + font-size: 4em; + margin: 0; + padding-bottom: 0.2em; +} +h2 { + margin-top: 1.3em; + padding-bottom: 0em; + margin-bottom:0; +} .view-source { float: right } diff --git a/samples/static/css/chat.css b/samples/static/css/chat.css --- a/samples/static/css/chat.css +++ b/samples/static/css/chat.css @@ -1,106 +1,106 @@ -body { - background: #333; - color: #ccc; - font-family: 'Annie Use Your Telescope'; - font-size: 26px; - text-shadow: #000 3px 1px 3px; - padding:0; - margin:0; - background: url(wood-bg.png) #333; -} -.header { - font-family: 'Fredericka the Great', cursive; - font-size: 50px; - color: #ad1c43; - float: left; - padding: 10px 20px; - position:absolute; - z-index:2; -} -.message-area { - clear:both; - padding: 20px; - color: #fff; - position: absolute; - top: 1em; - right:0; - left:0; - bottom:10%; - overflow: auto; -} -.gradient { - background: url(fade.png) repeat-x; - position:absolute; - top:0; - height: 150px; - left:0; - right:0; - z-index:1; -} -.send-area { - z-index:0; - position:fixed; - top:90%; - left:0; - right:0; - bottom:0; - background:#fff; -} -.send-textarea { - padding: 0.25em; - border:0; - position: absolute; - left:0; - width:100%; - bottom:0; - top:-1px; - font-family: 'Annie Use Your Telescope'; - font-size: 25px; - background: #111; - color: #999; -} -.message { - margin-top: 1em; - border-top: 0.1em dotted #333; -} -.message .timestamp { - color: #888; - font-size: 15px; - display: inline; - float: right; -} -.message .name { - display: inline-block; - font-size: 18px; - font-style: italic; - float:left; -} -.message .content { - display:block; - clear:both; -} -.name-area { - position: absolute; - top: 20px; - right: 20px; - z-index: 3; -} -.name-input { - background: #111; - border: 0; - border-radius: 0.3em; - font-family: 'Annie Use Your Telescope'; - color: #777; - font-size: 20px; - padding-left: 0.2em; -} -.name-input:focus,.send-textarea:focus { - background: #333; -} -.view-source { - position: absolute; - z-index: 4; - right: 20px; - color: #555; - top: 100px; -} +body { + background: #333; + color: #ccc; + font-family: 'Annie Use Your Telescope'; + font-size: 26px; + text-shadow: #000 3px 1px 3px; + padding:0; + margin:0; + background: url(wood-bg.png) #333; +} +.header { + font-family: 'Fredericka the Great', cursive; + font-size: 50px; + color: #ad1c43; + float: left; + padding: 10px 20px; + position:absolute; + z-index:2; +} +.message-area { + clear:both; + padding: 20px; + color: #fff; + position: absolute; + top: 1em; + right:0; + left:0; + bottom:10%; + overflow: auto; +} +.gradient { + background: url(fade.png) repeat-x; + position:absolute; + top:0; + height: 150px; + left:0; + right:0; + z-index:1; +} +.send-area { + z-index:0; + position:fixed; + top:90%; + left:0; + right:0; + bottom:0; + background:#fff; +} +.send-textarea { + padding: 0.25em; + border:0; + position: absolute; + left:0; + width:100%; + bottom:0; + top:-1px; + font-family: 'Annie Use Your Telescope'; + font-size: 25px; + background: #111; + color: #999; +} +.message { + margin-top: 1em; + border-top: 0.1em dotted #333; +} +.message .timestamp { + color: #888; + font-size: 15px; + display: inline; + float: right; +} +.message .name { + display: inline-block; + font-size: 18px; + font-style: italic; + float:left; +} +.message .content { + display:block; + clear:both; +} +.name-area { + position: absolute; + top: 20px; + right: 20px; + z-index: 3; +} +.name-input { + background: #111; + border: 0; + border-radius: 0.3em; + font-family: 'Annie Use Your Telescope'; + color: #777; + font-size: 20px; + padding-left: 0.2em; +} +.name-input:focus,.send-textarea:focus { + background: #333; +} +.view-source { + position: absolute; + z-index: 4; + right: 20px; + color: #555; + top: 100px; +} diff --git a/src/Foreign/JavaScript.hs b/src/Foreign/JavaScript.hs --- a/src/Foreign/JavaScript.hs +++ b/src/Foreign/JavaScript.hs @@ -1,110 +1,110 @@ -{-# LANGUAGE RecordWildCards #-} -module Foreign.JavaScript ( - -- * Synopsis - -- | A JavaScript foreign function interface (FFI). - -- - -- 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" - -- library, but the types are /not/ compatible directly - -- (although some escape hatches are provided). - -- Use "Foreign.JavaScript" only if you want to roll your own - -- interface to the web browser. - - -- * Server - serve, defaultConfig, Config( - jsPort, jsAddr - , jsCustomHTML, jsStatic, jsLog - , jsWindowReloadOnDisconnect, jsCallBufferMode), - Server, MimeType, URI, loadFile, loadDirectory, - Window, getServer, getCookies, root, - - -- * JavaScript FFI - ToJS(..), FromJS, JSFunction, JSObject, JavaScriptException, - FFI, ffi, runFunction, callFunction, - NewJSObject, unsafeCreateJSObject, - CallBufferMode(..), setCallBufferMode, getCallBufferMode, 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.CallBuffer -import Foreign.JavaScript.EventLoop -import Foreign.JavaScript.Marshal -import Foreign.JavaScript.Server -import Foreign.JavaScript.Types -import Foreign.RemotePtr as Foreign - -{----------------------------------------------------------------------------- - Server -------------------------------------------------------------------------------} --- | Run a "Foreign.JavaScript" server. -serve - :: Config -- ^ Configuration options. - -> (Window -> IO ()) -- ^ Initialization whenever a client connects. - -> IO () -serve config init = httpComm config $ eventLoop $ \w -> do - setCallBufferMode w (jsCallBufferMode config) - 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 = 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. --- --- WARNING: This function assumes that the supplied JavaScript code does, --- in fact, create an object that is new. -unsafeCreateJSObject :: Window -> JSFunction NewJSObject -> IO JSObject -unsafeCreateJSObject w f = do - g <- wrapImposeStablePtr w f - 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 - --- | Export a Haskell function as an event handler. --- --- The result is a JavaScript @Function@ object that can be called --- from JavaScript like a regular function. However, --- the corresponding Haskell function will /not/ be run immediately, --- rather it will be added to the event queue and processed --- like an event. In other words, this the Haskell code is only called --- asynchronously. --- --- WARNING: The event handler will be garbage collected unless you --- keep a reference to it /on the Haskell side/! --- Registering it with a JavaScript function will generally /not/ --- keep it alive. -exportHandler :: IsHandler a => Window -> a -> IO JSObject -exportHandler w f = do - 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 +{-# LANGUAGE RecordWildCards #-} +module Foreign.JavaScript ( + -- * Synopsis + -- | A JavaScript foreign function interface (FFI). + -- + -- 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" + -- library, but the types are /not/ compatible directly + -- (although some escape hatches are provided). + -- Use "Foreign.JavaScript" only if you want to roll your own + -- interface to the web browser. + + -- * Server + serve, defaultConfig, Config( + jsPort, jsAddr + , jsCustomHTML, jsStatic, jsLog + , jsWindowReloadOnDisconnect, jsCallBufferMode), + Server, MimeType, URI, loadFile, loadDirectory, + Window, getServer, getCookies, root, + + -- * JavaScript FFI + ToJS(..), FromJS, JSFunction, JSObject, JavaScriptException, + FFI, ffi, runFunction, callFunction, + NewJSObject, unsafeCreateJSObject, + CallBufferMode(..), setCallBufferMode, getCallBufferMode, 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.CallBuffer +import Foreign.JavaScript.EventLoop +import Foreign.JavaScript.Marshal +import Foreign.JavaScript.Server +import Foreign.JavaScript.Types +import Foreign.RemotePtr as Foreign + +{----------------------------------------------------------------------------- + Server +------------------------------------------------------------------------------} +-- | Run a "Foreign.JavaScript" server. +serve + :: Config -- ^ Configuration options. + -> (Window -> IO ()) -- ^ Initialization whenever a client connects. + -> IO () +serve config init = httpComm config $ eventLoop $ \w -> do + setCallBufferMode w (jsCallBufferMode config) + 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 = 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. +-- +-- WARNING: This function assumes that the supplied JavaScript code does, +-- in fact, create an object that is new. +unsafeCreateJSObject :: Window -> JSFunction NewJSObject -> IO JSObject +unsafeCreateJSObject w f = do + g <- wrapImposeStablePtr w f + 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 + +-- | Export a Haskell function as an event handler. +-- +-- The result is a JavaScript @Function@ object that can be called +-- from JavaScript like a regular function. However, +-- the corresponding Haskell function will /not/ be run immediately, +-- rather it will be added to the event queue and processed +-- like an event. In other words, this the Haskell code is only called +-- asynchronously. +-- +-- WARNING: The event handler will be garbage collected unless you +-- keep a reference to it /on the Haskell side/! +-- Registering it with a JavaScript function will generally /not/ +-- keep it alive. +exportHandler :: IsHandler a => Window -> a -> IO JSObject +exportHandler w f = do + 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 diff --git a/src/Foreign/JavaScript/CallBuffer.hs b/src/Foreign/JavaScript/CallBuffer.hs --- a/src/Foreign/JavaScript/CallBuffer.hs +++ b/src/Foreign/JavaScript/CallBuffer.hs @@ -1,50 +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 +{-# 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 diff --git a/src/Foreign/JavaScript/EventLoop.hs b/src/Foreign/JavaScript/EventLoop.hs --- a/src/Foreign/JavaScript/EventLoop.hs +++ b/src/Foreign/JavaScript/EventLoop.hs @@ -1,201 +1,201 @@ -{-# LANGUAGE RecordWildCards, CPP #-} -{-# LANGUAGE RecursiveDo #-} -module Foreign.JavaScript.EventLoop ( - eventLoop, - runEval, callEval, debug, onDisconnect, - newHandler, fromJSStablePtr, - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM as STM -import Control.DeepSeq (deepseq) -import Control.Exception as E -import Control.Monad -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS -import Data.IORef -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified System.Mem - -import Foreign.RemotePtr as Foreign -import Foreign.JavaScript.CallBuffer -import Foreign.JavaScript.Types - -rebug :: IO () -#ifdef REBUG -rebug = System.Mem.performGC -#else -rebug = return () -#endif - -{----------------------------------------------------------------------------- - Event Loop -------------------------------------------------------------------------------} --- | Handle a single event -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) -> EventLoop -eventLoop init server info comm = void $ do - -- 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 - 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 Result), ServerMsg)) - -- The thread `handleEvents` handles client Events in order. - - -- 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. - let run msg = msg `deepseq` do -- see [ServerMsg strictness] - atomicallyIfOpen $ writeTQueue calls (Nothing , msg) - call msg = msg `deepseq` do -- see [ServerMsg strictness] - ref <- newEmptyTMVarIO - 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 - - w0 <- newPartialWindow - let w = w0 { getServer = server - , getCookies = info - , runEval = run . RunEval - , callEval = call . CallEval - , debug = debug - , timestamp = run Timestamp - , onDisconnect = onDisconnect - } - - -- The individual threads are as follows: - -- - -- Read client messages and send them to the - -- thread that handles events or the thread that handles FFI calls. - 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 - writeServer comm msg - return ref - 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 - 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 - - -- Execute an IO action, but also print any exceptions that it may throw. - -- (The exception is rethrown.) - let - printException :: IO a -> IO a - printException = E.handle $ \e -> do - sLog server . BS.pack $ show (e :: E.SomeException) - E.throwIO e - - -- 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 $ \_ -> - withAsync (flushCallBufferPeriodically w) $ \_ -> - 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 - --- | Thread that periodically flushes the call buffer -flushCallBufferPeriodically :: Window -> IO () -flushCallBufferPeriodically w = - forever $ threadDelay (flushPeriod*1000) >> flushCallBuffer w - - -{----------------------------------------------------------------------------- - Exports, Imports and garbage collection -------------------------------------------------------------------------------} --- | Turn a Haskell function into an event handler. -newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent -newHandler w@(Window{..}) handler = do - coupon <- newCoupon wEventHandlers - newRemotePtr coupon (handler . parseArgs) wEventHandlers - where - fromSuccess (JSON.Success x) = x - -- parse a genuine JavaScript array - parseArgs x = fromSuccess (JSON.fromJSON x) :: [JSON.Value] - -- parse a JavaScript arguments object - -- parseArgs x = Map.elems (fromSuccess (JSON.fromJSON x) :: Map.Map String JSON.Value) - - --- | Convert a stable pointer from JavaScript into a 'JSObject'. -fromJSStablePtr :: JSON.Value -> Window -> IO JSObject -fromJSStablePtr js w@(Window{..}) = do - let JSON.Success coupon = JSON.fromJSON js - mhs <- Foreign.lookup coupon wJSObjects - case mhs of - Just hs -> return hs - Nothing -> do - ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects - addFinalizer ptr $ - runEval ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')") - return ptr - +{-# LANGUAGE RecordWildCards, CPP #-} +{-# LANGUAGE RecursiveDo #-} +module Foreign.JavaScript.EventLoop ( + eventLoop, + runEval, callEval, debug, onDisconnect, + newHandler, fromJSStablePtr, + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM as STM +import Control.DeepSeq (deepseq) +import Control.Exception as E +import Control.Monad +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import Data.IORef +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified System.Mem + +import Foreign.RemotePtr as Foreign +import Foreign.JavaScript.CallBuffer +import Foreign.JavaScript.Types + +rebug :: IO () +#ifdef REBUG +rebug = System.Mem.performGC +#else +rebug = return () +#endif + +{----------------------------------------------------------------------------- + Event Loop +------------------------------------------------------------------------------} +-- | Handle a single event +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) -> EventLoop +eventLoop init server info comm = void $ do + -- 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 + 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 Result), ServerMsg)) + -- The thread `handleEvents` handles client Events in order. + + -- 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. + let run msg = msg `deepseq` do -- see [ServerMsg strictness] + atomicallyIfOpen $ writeTQueue calls (Nothing , msg) + call msg = msg `deepseq` do -- see [ServerMsg strictness] + ref <- newEmptyTMVarIO + 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 + + w0 <- newPartialWindow + let w = w0 { getServer = server + , getCookies = info + , runEval = run . RunEval + , callEval = call . CallEval + , debug = debug + , timestamp = run Timestamp + , onDisconnect = onDisconnect + } + + -- The individual threads are as follows: + -- + -- Read client messages and send them to the + -- thread that handles events or the thread that handles FFI calls. + 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 + writeServer comm msg + return ref + 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 + 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 + + -- Execute an IO action, but also print any exceptions that it may throw. + -- (The exception is rethrown.) + let + printException :: IO a -> IO a + printException = E.handle $ \e -> do + sLog server . BS.pack $ show (e :: E.SomeException) + E.throwIO e + + -- 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 $ \_ -> + withAsync (flushCallBufferPeriodically w) $ \_ -> + 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 + +-- | Thread that periodically flushes the call buffer +flushCallBufferPeriodically :: Window -> IO () +flushCallBufferPeriodically w = + forever $ threadDelay (flushPeriod*1000) >> flushCallBuffer w + + +{----------------------------------------------------------------------------- + Exports, Imports and garbage collection +------------------------------------------------------------------------------} +-- | Turn a Haskell function into an event handler. +newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent +newHandler w@(Window{..}) handler = do + coupon <- newCoupon wEventHandlers + newRemotePtr coupon (handler . parseArgs) wEventHandlers + where + fromSuccess (JSON.Success x) = x + -- parse a genuine JavaScript array + parseArgs x = fromSuccess (JSON.fromJSON x) :: [JSON.Value] + -- parse a JavaScript arguments object + -- parseArgs x = Map.elems (fromSuccess (JSON.fromJSON x) :: Map.Map String JSON.Value) + + +-- | Convert a stable pointer from JavaScript into a 'JSObject'. +fromJSStablePtr :: JSON.Value -> Window -> IO JSObject +fromJSStablePtr js w@(Window{..}) = do + let JSON.Success coupon = JSON.fromJSON js + mhs <- Foreign.lookup coupon wJSObjects + case mhs of + Just hs -> return hs + Nothing -> do + ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects + addFinalizer ptr $ + runEval ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')") + return ptr + diff --git a/src/Foreign/JavaScript/Include.hs b/src/Foreign/JavaScript/Include.hs --- a/src/Foreign/JavaScript/Include.hs +++ b/src/Foreign/JavaScript/Include.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} -module Foreign.JavaScript.Include (include) where - -import Data.Functor -import Data.FileEmbed (makeRelativeToProject) -import Language.Haskell.TH -import System.IO - -include :: FilePath -> Q Exp -include path = do - path <- makeRelativeToProject path - LitE . StringL <$> runIO (readFileUTF8 path) - -readFileUTF8 :: FilePath -> IO String -readFileUTF8 path = do - h <- openFile path ReadMode - hSetEncoding h utf8 - hGetContents h +{-# LANGUAGE TemplateHaskell, CPP #-} +module Foreign.JavaScript.Include (include) where + +import Data.Functor +import Data.FileEmbed (makeRelativeToProject) +import Language.Haskell.TH +import System.IO + +include :: FilePath -> Q Exp +include path = do + path <- makeRelativeToProject path + LitE . StringL <$> runIO (readFileUTF8 path) + +readFileUTF8 :: FilePath -> IO String +readFileUTF8 path = do + h <- openFile path ReadMode + hSetEncoding h utf8 + hGetContents h diff --git a/src/Foreign/JavaScript/Marshal.hs b/src/Foreign/JavaScript/Marshal.hs --- a/src/Foreign/JavaScript/Marshal.hs +++ b/src/Foreign/JavaScript/Marshal.hs @@ -1,249 +1,249 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -module Foreign.JavaScript.Marshal ( - ToJS(..), FromJS, - FFI, JSFunction, toCode, marshalResult, ffi, - IsHandler, convertArguments, handle, - - NewJSObject, wrapImposeStablePtr, - ) where - -import Data.Aeson as JSON -#if defined(CABAL) -#if MIN_VERSION_aeson(1,0,0) -import qualified Data.Aeson.Text as JSON (encodeToTextBuilder) -#else -import qualified Data.Aeson.Encode as JSON (encodeToTextBuilder) -#endif -#else -import qualified Data.Aeson.Text as JSON (encodeToTextBuilder) -#endif -import qualified Data.Aeson.Types as JSON -import Data.Functor ((<$>)) -import Data.List (intercalate) -import qualified Data.Text as T -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.Vector as Vector -import Safe (atMay) - -import Foreign.JavaScript.EventLoop (fromJSStablePtr) -import Foreign.JavaScript.Types -import Foreign.RemotePtr - -{----------------------------------------------------------------------------- - Convert Haskell values to JavaScript values -------------------------------------------------------------------------------} --- | JavaScript code snippet. -newtype JSCode = JSCode { unJSCode :: String } - deriving (Eq, Ord, Show) - --- | Helper class for rendering Haskell values as JavaScript expressions. -class ToJS a where - render :: a -> IO JSCode - renderList :: [a] -> IO JSCode - - renderList xs = do - ys <- mapM render xs - jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]" - -jsCode = return . JSCode - -instance ToJS Float where render = render . JSON.toJSON -instance ToJS Double where render = render . JSON.toJSON -instance ToJS Int where render = jsCode . show -instance ToJS Bool where render b = jsCode $ if b then "true" else "false" -instance ToJS JSON.Value where render = jsCode . showJSON -instance ToJS T.Text where render = render . JSON.String -instance ToJS Char where - render x = renderList [x] - renderList = render . JSON.String . T.pack - -instance ToJS a => ToJS [a] where - render = renderList - -instance ToJS HsEvent where - render x = render =<< unprotectedGetCoupon x -instance ToJS JSObject where - render x = apply1 "Haskell.deRefStablePtr(%1)" - <$> (render =<< unprotectedGetCoupon x) - --- | Show a type in a JSON compatible way. -showJSON :: ToJSON a => a -> String -showJSON - = Data.Text.Lazy.unpack - . Data.Text.Lazy.Builder.toLazyText - . JSON.encodeToTextBuilder . JSON.toJSON - -{----------------------------------------------------------------------------- - Convert JavaScript values to Haskell values -------------------------------------------------------------------------------} -data FromJS' a = FromJS' - { wrapCode :: (JSCode -> JSCode) - , marshal :: Window -> JSON.Value -> IO a - } - --- | Helper class for converting JavaScript values to Haskell values. -class FromJS a where - fromJS :: FromJS' a - --- | Marshal a simple type to Haskell. -simple :: FromJSON a => (JSCode -> JSCode) -> FromJS' a -simple f = - FromJS' { wrapCode = f , marshal = \_ -> fromSuccessIO . JSON.fromJSON } - where - fromSuccessIO (JSON.Success a) = return a - -instance FromJS String where fromJS = simple $ apply1 "%1.toString()" -instance FromJS T.Text where fromJS = simple $ apply1 "%1.toString()" -instance FromJS Int where fromJS = simple id -instance FromJS Double where fromJS = simple id -instance FromJS Float where fromJS = simple id -instance FromJS JSON.Value where fromJS = simple id - -instance FromJS () where - fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return () } - -instance FromJS JSObject where - fromJS = FromJS' - { wrapCode = apply1 "Haskell.getStablePtr(%1)" - , marshal = \w v -> fromJSStablePtr v w - } - --- FIXME: Not sure whether this instance is really a good idea. -instance FromJS [JSObject] where - fromJS = FromJS' - { wrapCode = apply1 "Haskell.map(Haskell.getStablePtr, %1)" - , marshal = \w (JSON.Array vs) -> do - mapM (\v -> fromJSStablePtr v w) (Vector.toList vs) - } - -instance FromJS NewJSObject where - fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return NewJSObject } - -wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject) -wrapImposeStablePtr w@(Window{..}) f = do - coupon <- newCoupon wJSObjects - rcoupon <- render coupon - rcode <- code f - return $ JSFunction - { code = return $ apply "Haskell.imposeStablePtr(%1,%2)" [rcode, rcoupon] - , marshalResult = \w _ -> newRemotePtr coupon (JSPtr coupon) wJSObjects - } - -{----------------------------------------------------------------------------- - Variable argument JavaScript functions -------------------------------------------------------------------------------} --- | A JavaScript function with a given output type @a@. -data JSFunction a = JSFunction - { code :: IO JSCode - -- ^ Code snippet that implements the function. - , marshalResult :: Window -> JSON.Value -> IO a - -- ^ Marshal the function result to a Haskell value. - } - --- | Change the output type of a 'JSFunction'. -instance Functor JSFunction where - fmap f (JSFunction c m) = JSFunction c (\w v -> fmap f $ m w v) - --- | Render function to a textual representation using JavaScript syntax. -toCode :: JSFunction a -> IO String -toCode = fmap unJSCode . code - - --- | Helper class for making 'ffi' a variable argument function. -class FFI a where - fancy :: ([JSCode] -> IO JSCode) -> a - -instance (ToJS a, FFI b) => FFI (a -> b) where - fancy f a = fancy $ \xs -> do - x <- render a - f (x:xs) - -instance FromJS b => FFI (JSFunction b) where - fancy f = JSFunction - { code = wrapCode b <$> f [] - , marshalResult = marshal b - } - where b = fromJS - --- | Simple JavaScript FFI with string substitution. --- --- Inspired by the Fay language. --- --- > example :: String -> Int -> JSFunction String --- > example = ffi "$(%1).prop('checked',%2)" --- --- The 'ffi' function takes a string argument representing the JavaScript --- code to be executed on the client. --- Occurrences of the substrings @%1@ to @%9@ will be replaced by --- subequent arguments. --- The substring @%%@ in the original will be replaced by @%@ (character escape). --- --- Note: Always specify a type signature! The types automate --- how values are marshalled between Haskell and JavaScript. --- The class instances for the 'FFI' class show which conversions are supported. --- -ffi :: FFI a => String -> a -ffi macro = fancy (return . apply macro) - -testFFI :: String -> Int -> JSFunction String -testFFI = ffi "$(%1).prop('checked',%2)" - -{----------------------------------------------------------------------------- - Type classes -------------------------------------------------------------------------------} --- | Helper class for exporting Haskell functions to JavaScript --- as event handlers. -class IsHandler a where - convertArgs :: a -> Int -> [JSCode] - handle :: a -> Window -> [JSON.Value] -> IO () - -instance (FromJS a, IsHandler b) => IsHandler (a -> b) where - convertArgs = convertArgs' - handle f = \w (a:as) -> do - x <- marshal fromJS w a - handle (f x) w as - -convertArgs' :: forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode] -convertArgs' f n = wrap arg : convertArgs (f x) (n+1) - where - x = undefined :: a - wrap = wrapCode (fromJS :: FromJS' a) - arg = JSCode $ "arguments[" ++ show n ++ "]" - -instance IsHandler (IO ()) where - convertArgs _ _ = [] - handle m = \_ _ -> m - --- | Code needed to preconvert arguments on the JavaScript side. -convertArguments :: IsHandler a => a -> String -convertArguments f = - "[" ++ intercalate "," (map unJSCode $ convertArgs f 0) ++ "]" - - -{----------------------------------------------------------------------------- - String utilities -------------------------------------------------------------------------------} --- | String substitution. --- Substitute occurences of %1, %2 up to %9 with the argument strings. --- The types ensure that the % character has no meaning in the generated output. --- --- > apply "%1 and %2" [x,y] = x ++ " and " ++ y -apply :: String -> [JSCode] -> JSCode -apply code args = JSCode $ go code - where - at xs i = maybe (error err) id $ atMay xs i - err = "Graphics.UI.Threepenny.FFI: Too few arguments in FFI call!" - argument i = unJSCode (args `at` i) - - go [] = [] - go ('%':'%':cs) = '%' : go cs - go ('%':c :cs) = argument index ++ go cs - where index = fromEnum c - fromEnum '1' - go (c:cs) = c : go cs - --- | Apply string substitution that expects a single argument. -apply1 :: String -> JSCode -> JSCode -apply1 s x = apply s [x] +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +module Foreign.JavaScript.Marshal ( + ToJS(..), FromJS, + FFI, JSFunction, toCode, marshalResult, ffi, + IsHandler, convertArguments, handle, + + NewJSObject, wrapImposeStablePtr, + ) where + +import Data.Aeson as JSON +#if defined(CABAL) +#if MIN_VERSION_aeson(1,0,0) +import qualified Data.Aeson.Text as JSON (encodeToTextBuilder) +#else +import qualified Data.Aeson.Encode as JSON (encodeToTextBuilder) +#endif +#else +import qualified Data.Aeson.Text as JSON (encodeToTextBuilder) +#endif +import qualified Data.Aeson.Types as JSON +import Data.Functor ((<$>)) +import Data.List (intercalate) +import qualified Data.Text as T +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Data.Vector as Vector +import Safe (atMay) + +import Foreign.JavaScript.EventLoop (fromJSStablePtr) +import Foreign.JavaScript.Types +import Foreign.RemotePtr + +{----------------------------------------------------------------------------- + Convert Haskell values to JavaScript values +------------------------------------------------------------------------------} +-- | JavaScript code snippet. +newtype JSCode = JSCode { unJSCode :: String } + deriving (Eq, Ord, Show) + +-- | Helper class for rendering Haskell values as JavaScript expressions. +class ToJS a where + render :: a -> IO JSCode + renderList :: [a] -> IO JSCode + + renderList xs = do + ys <- mapM render xs + jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]" + +jsCode = return . JSCode + +instance ToJS Float where render = render . JSON.toJSON +instance ToJS Double where render = render . JSON.toJSON +instance ToJS Int where render = jsCode . show +instance ToJS Bool where render b = jsCode $ if b then "true" else "false" +instance ToJS JSON.Value where render = jsCode . showJSON +instance ToJS T.Text where render = render . JSON.String +instance ToJS Char where + render x = renderList [x] + renderList = render . JSON.String . T.pack + +instance ToJS a => ToJS [a] where + render = renderList + +instance ToJS HsEvent where + render x = render =<< unprotectedGetCoupon x +instance ToJS JSObject where + render x = apply1 "Haskell.deRefStablePtr(%1)" + <$> (render =<< unprotectedGetCoupon x) + +-- | Show a type in a JSON compatible way. +showJSON :: ToJSON a => a -> String +showJSON + = Data.Text.Lazy.unpack + . Data.Text.Lazy.Builder.toLazyText + . JSON.encodeToTextBuilder . JSON.toJSON + +{----------------------------------------------------------------------------- + Convert JavaScript values to Haskell values +------------------------------------------------------------------------------} +data FromJS' a = FromJS' + { wrapCode :: (JSCode -> JSCode) + , marshal :: Window -> JSON.Value -> IO a + } + +-- | Helper class for converting JavaScript values to Haskell values. +class FromJS a where + fromJS :: FromJS' a + +-- | Marshal a simple type to Haskell. +simple :: FromJSON a => (JSCode -> JSCode) -> FromJS' a +simple f = + FromJS' { wrapCode = f , marshal = \_ -> fromSuccessIO . JSON.fromJSON } + where + fromSuccessIO (JSON.Success a) = return a + +instance FromJS String where fromJS = simple $ apply1 "%1.toString()" +instance FromJS T.Text where fromJS = simple $ apply1 "%1.toString()" +instance FromJS Int where fromJS = simple id +instance FromJS Double where fromJS = simple id +instance FromJS Float where fromJS = simple id +instance FromJS JSON.Value where fromJS = simple id + +instance FromJS () where + fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return () } + +instance FromJS JSObject where + fromJS = FromJS' + { wrapCode = apply1 "Haskell.getStablePtr(%1)" + , marshal = \w v -> fromJSStablePtr v w + } + +-- FIXME: Not sure whether this instance is really a good idea. +instance FromJS [JSObject] where + fromJS = FromJS' + { wrapCode = apply1 "Haskell.map(Haskell.getStablePtr, %1)" + , marshal = \w (JSON.Array vs) -> do + mapM (\v -> fromJSStablePtr v w) (Vector.toList vs) + } + +instance FromJS NewJSObject where + fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return NewJSObject } + +wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject) +wrapImposeStablePtr w@(Window{..}) f = do + coupon <- newCoupon wJSObjects + rcoupon <- render coupon + rcode <- code f + return $ JSFunction + { code = return $ apply "Haskell.imposeStablePtr(%1,%2)" [rcode, rcoupon] + , marshalResult = \w _ -> newRemotePtr coupon (JSPtr coupon) wJSObjects + } + +{----------------------------------------------------------------------------- + Variable argument JavaScript functions +------------------------------------------------------------------------------} +-- | A JavaScript function with a given output type @a@. +data JSFunction a = JSFunction + { code :: IO JSCode + -- ^ Code snippet that implements the function. + , marshalResult :: Window -> JSON.Value -> IO a + -- ^ Marshal the function result to a Haskell value. + } + +-- | Change the output type of a 'JSFunction'. +instance Functor JSFunction where + fmap f (JSFunction c m) = JSFunction c (\w v -> fmap f $ m w v) + +-- | Render function to a textual representation using JavaScript syntax. +toCode :: JSFunction a -> IO String +toCode = fmap unJSCode . code + + +-- | Helper class for making 'ffi' a variable argument function. +class FFI a where + fancy :: ([JSCode] -> IO JSCode) -> a + +instance (ToJS a, FFI b) => FFI (a -> b) where + fancy f a = fancy $ \xs -> do + x <- render a + f (x:xs) + +instance FromJS b => FFI (JSFunction b) where + fancy f = JSFunction + { code = wrapCode b <$> f [] + , marshalResult = marshal b + } + where b = fromJS + +-- | Simple JavaScript FFI with string substitution. +-- +-- Inspired by the Fay language. +-- +-- > example :: String -> Int -> JSFunction String +-- > example = ffi "$(%1).prop('checked',%2)" +-- +-- The 'ffi' function takes a string argument representing the JavaScript +-- code to be executed on the client. +-- Occurrences of the substrings @%1@ to @%9@ will be replaced by +-- subequent arguments. +-- The substring @%%@ in the original will be replaced by @%@ (character escape). +-- +-- Note: Always specify a type signature! The types automate +-- how values are marshalled between Haskell and JavaScript. +-- The class instances for the 'FFI' class show which conversions are supported. +-- +ffi :: FFI a => String -> a +ffi macro = fancy (return . apply macro) + +testFFI :: String -> Int -> JSFunction String +testFFI = ffi "$(%1).prop('checked',%2)" + +{----------------------------------------------------------------------------- + Type classes +------------------------------------------------------------------------------} +-- | Helper class for exporting Haskell functions to JavaScript +-- as event handlers. +class IsHandler a where + convertArgs :: a -> Int -> [JSCode] + handle :: a -> Window -> [JSON.Value] -> IO () + +instance (FromJS a, IsHandler b) => IsHandler (a -> b) where + convertArgs = convertArgs' + handle f = \w (a:as) -> do + x <- marshal fromJS w a + handle (f x) w as + +convertArgs' :: forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode] +convertArgs' f n = wrap arg : convertArgs (f x) (n+1) + where + x = undefined :: a + wrap = wrapCode (fromJS :: FromJS' a) + arg = JSCode $ "arguments[" ++ show n ++ "]" + +instance IsHandler (IO ()) where + convertArgs _ _ = [] + handle m = \_ _ -> m + +-- | Code needed to preconvert arguments on the JavaScript side. +convertArguments :: IsHandler a => a -> String +convertArguments f = + "[" ++ intercalate "," (map unJSCode $ convertArgs f 0) ++ "]" + + +{----------------------------------------------------------------------------- + String utilities +------------------------------------------------------------------------------} +-- | String substitution. +-- Substitute occurences of %1, %2 up to %9 with the argument strings. +-- The types ensure that the % character has no meaning in the generated output. +-- +-- > apply "%1 and %2" [x,y] = x ++ " and " ++ y +apply :: String -> [JSCode] -> JSCode +apply code args = JSCode $ go code + where + at xs i = maybe (error err) id $ atMay xs i + err = "Graphics.UI.Threepenny.FFI: Too few arguments in FFI call!" + argument i = unJSCode (args `at` i) + + go [] = [] + go ('%':'%':cs) = '%' : go cs + go ('%':c :cs) = argument index ++ go cs + where index = fromEnum c - fromEnum '1' + go (c:cs) = c : go cs + +-- | Apply string substitution that expects a single argument. +apply1 :: String -> JSCode -> JSCode +apply1 s x = apply s [x] diff --git a/src/Foreign/JavaScript/Resources.hs b/src/Foreign/JavaScript/Resources.hs --- a/src/Foreign/JavaScript/Resources.hs +++ b/src/Foreign/JavaScript/Resources.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE TemplateHaskell #-} -module Foreign.JavaScript.Resources where - -import Data.Text (Text) -import qualified Data.Text as Text -import Foreign.JavaScript.Include - -jsDriverCode :: Text -jsDriverCode = Text.unlines $ map Text.pack - [ $(include "js/lib/jquery.js") - , $(include "js/lib/jquery-cookie.js") - , "var Haskell = {};" - , $(include "js/comm.js") - , $(include "js/ffi.js") - , $(include "js/lib.js") - , $(include "js/log.js") - ] - -cssDriverCode :: Text -cssDriverCode = Text.pack $(include "js/haskell.css") - -defaultHtmlFile :: Text -defaultHtmlFile = Text.pack $(include "js/index.html") +{-# LANGUAGE TemplateHaskell #-} +module Foreign.JavaScript.Resources where + +import Data.Text (Text) +import qualified Data.Text as Text +import Foreign.JavaScript.Include + +jsDriverCode :: Text +jsDriverCode = Text.unlines $ map Text.pack + [ $(include "js/lib/jquery.js") + , $(include "js/lib/jquery-cookie.js") + , "var Haskell = {};" + , $(include "js/comm.js") + , $(include "js/ffi.js") + , $(include "js/lib.js") + , $(include "js/log.js") + ] + +cssDriverCode :: Text +cssDriverCode = Text.pack $(include "js/haskell.css") + +defaultHtmlFile :: Text +defaultHtmlFile = Text.pack $(include "js/index.html") diff --git a/src/Foreign/JavaScript/Server.hs b/src/Foreign/JavaScript/Server.hs --- a/src/Foreign/JavaScript/Server.hs +++ b/src/Foreign/JavaScript/Server.hs @@ -1,180 +1,180 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings #-} -module Foreign.JavaScript.Server ( - 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 -import System.FilePath - --- import web libraries -import Data.Aeson ((.=)) -import qualified Data.Aeson as JSON -import qualified Network.WebSockets as WS -import qualified Network.WebSockets.Snap as WS -import Snap.Core as Snap -import qualified Snap.Http.Server as Snap -import Snap.Util.FileServe - --- import internal modules -import Foreign.JavaScript.Resources -import Foreign.JavaScript.Types - -{----------------------------------------------------------------------------- - HTTP Server using WebSockets -------------------------------------------------------------------------------} --- | Run a HTTP server that creates a 'Comm' channel. -httpComm :: Config -> EventLoop -> IO () -httpComm Config{..} worker = do - env <- getEnvironment - let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env - let addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env - - let config = Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv)) - $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv)) - $ Snap.setErrorLog (Snap.ConfigIoLog jsLog) - $ Snap.setAccessLog (Snap.ConfigIoLog jsLog) - $ Snap.defaultConfig - - server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths <*> return jsLog - - Snap.httpServe config . route $ - routeResources server jsCustomHTML jsStatic - ++ routeWebsockets (worker server) - --- | Route the communication between JavaScript and the server -routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes -routeWebsockets worker = [("websocket", response)] - where - response = do - requestInfo <- Snap.getRequest - WS.runWebSocketsSnap $ \ws -> void $ do - comm <- communicationFromWebSocket ws - worker (rqCookies requestInfo) comm - -- error "Foreign.JavaScript: unreachable code path." - --- | Create 'Comm' channel from WebSocket request. -communicationFromWebSocket :: WS.PendingConnection -> IO Comm -communicationFromWebSocket request = do - 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 - x <- atomically $ STM.readTQueue commOut - -- see note [ServerMsg strictness] - WS.sendTextData connection . JSON.encode $ x - - -- read data from browser - let readData = forever $ do - input <- WS.receiveData connection - case input of - "ping" -> WS.sendTextData connection . LBS.pack $ "pong" - "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 - - -- 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 {..} - -{----------------------------------------------------------------------------- - Resources -------------------------------------------------------------------------------} -type Routes = [(ByteString, Snap ())] - -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) - Nothing -> logError "Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic" - Nothing -> writeTextMime defaultHtmlFile "text/html" - -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 - +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +module Foreign.JavaScript.Server ( + 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 +import System.FilePath + +-- import web libraries +import Data.Aeson ((.=)) +import qualified Data.Aeson as JSON +import qualified Network.WebSockets as WS +import qualified Network.WebSockets.Snap as WS +import Snap.Core as Snap +import qualified Snap.Http.Server as Snap +import Snap.Util.FileServe + +-- import internal modules +import Foreign.JavaScript.Resources +import Foreign.JavaScript.Types + +{----------------------------------------------------------------------------- + HTTP Server using WebSockets +------------------------------------------------------------------------------} +-- | Run a HTTP server that creates a 'Comm' channel. +httpComm :: Config -> EventLoop -> IO () +httpComm Config{..} worker = do + env <- getEnvironment + let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env + let addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env + + let config = Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv)) + $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv)) + $ Snap.setErrorLog (Snap.ConfigIoLog jsLog) + $ Snap.setAccessLog (Snap.ConfigIoLog jsLog) + $ Snap.defaultConfig + + server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths <*> return jsLog + + Snap.httpServe config . route $ + routeResources server jsCustomHTML jsStatic + ++ routeWebsockets (worker server) + +-- | Route the communication between JavaScript and the server +routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes +routeWebsockets worker = [("websocket", response)] + where + response = do + requestInfo <- Snap.getRequest + WS.runWebSocketsSnap $ \ws -> void $ do + comm <- communicationFromWebSocket ws + worker (rqCookies requestInfo) comm + -- error "Foreign.JavaScript: unreachable code path." + +-- | Create 'Comm' channel from WebSocket request. +communicationFromWebSocket :: WS.PendingConnection -> IO Comm +communicationFromWebSocket request = do + 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 + x <- atomically $ STM.readTQueue commOut + -- see note [ServerMsg strictness] + WS.sendTextData connection . JSON.encode $ x + + -- read data from browser + let readData = forever $ do + input <- WS.receiveData connection + case input of + "ping" -> WS.sendTextData connection . LBS.pack $ "pong" + "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 + + -- 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 {..} + +{----------------------------------------------------------------------------- + Resources +------------------------------------------------------------------------------} +type Routes = [(ByteString, Snap ())] + +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) + Nothing -> logError "Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic" + Nothing -> writeTextMime defaultHtmlFile "text/html" + +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 + diff --git a/src/Foreign/JavaScript/Types.hs b/src/Foreign/JavaScript/Types.hs --- a/src/Foreign/JavaScript/Types.hs +++ b/src/Foreign/JavaScript/Types.hs @@ -1,313 +1,313 @@ -{-# 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 -import Control.DeepSeq -import Data.Aeson as JSON -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS (hPutStrLn) -import Data.IORef -import Data.Map as Map -import Data.String -import Data.Text -import Data.Typeable -import Snap.Core (Cookie(..)) -import System.IO (stderr) - -import Foreign.RemotePtr - -{----------------------------------------------------------------------------- - Server Configuration -- Static -------------------------------------------------------------------------------} --- 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. - -* @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. - -* @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. - -* @jsCallBufferMode :: CallBufferMode@ - - The initial 'CallBufferMode' to use for 'runFunction'. - It can be changed at any time with 'setCallBufferMode'. - -(For reasons of forward compatibility, the constructor is not exported.) - --} -data Config = Config - { jsPort :: Maybe Int - , jsAddr :: Maybe ByteString - , jsCustomHTML :: Maybe FilePath - , jsStatic :: Maybe FilePath - , jsLog :: ByteString -> IO () - , jsWindowReloadOnDisconnect :: Bool - , jsCallBufferMode :: CallBufferMode - } - -defaultPort :: Int -defaultPort = 8023 - -defaultAddr :: ByteString -defaultAddr = "127.0.0.1" - --- | Default configuration. --- --- Port from environment variable or @8023@, listening on @localhost@, --- no custom HTML, no static directory, --- logging to stderr, --- do reload on disconnect, --- __buffer FFI calls__. -defaultConfig :: Config -defaultConfig = Config - { jsPort = Nothing - , jsAddr = Nothing - , jsWindowReloadOnDisconnect = True - , jsCustomHTML = Nothing - , jsStatic = Nothing - , jsLog = BS.hPutStrLn stderr - , jsCallBufferMode = FlushOften - } - -{----------------------------------------------------------------------------- - 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 - , sLog :: ByteString -> IO () -- function for logging - } -type Filepaths = (Integer, Map ByteString (FilePath, MimeType)) -newFilepaths = (0, Map.empty) - -{----------------------------------------------------------------------------- - Communication channel -------------------------------------------------------------------------------} --- | Bidirectional communication channel. -data Comm = Comm - { 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 () -writeComm c = STM.writeTQueue (commOut c) - -readComm :: Comm -> STM JSON.Value -readComm c = STM.readTQueue (commIn c) - -{----------------------------------------------------------------------------- - Communication protocol -------------------------------------------------------------------------------} --- | Messages received from the JavaScript client. -data ClientMsg - = Event Coupon JSON.Value - | Result JSON.Value - | Exception String - | Quit - deriving (Eq, Show) - -instance FromJSON ClientMsg where - parseJSON (Object msg) = do - tag <- msg .: "tag" - case (tag :: Text) of - "Event" -> Event <$> (msg .: "name") <*> (msg .: "arguments") - "Result" -> Result <$> (msg .: "contents") - "Exception" -> Exception <$> (msg .: "contents") - "Quit" -> return Quit - -readClient :: Comm -> STM ClientMsg -readClient c = do - msg <- readComm c - case JSON.fromJSON msg of - Error s -> error $ "Foreign.JavaScript: Error parsing client message " ++ show s - Success x -> return x - --- | Messages sent by the Haskell server. -data ServerMsg - = RunEval String - | CallEval String - | Debug String - | Timestamp - deriving (Eq,Show) - -instance NFData ServerMsg where - rnf (RunEval x) = rnf x - rnf (CallEval x) = rnf x - rnf (Debug x) = rnf x - rnf (Timestamp ) = () - -instance ToJSON ServerMsg where - toJSON (Debug x) = object [ "tag" .= t "Debug" , "contents" .= toJSON x] - toJSON (Timestamp ) = object [ "tag" .= t "Timestamp" ] - toJSON (RunEval x) = object [ "tag" .= t "RunEval" , "contents" .= toJSON x] - toJSON (CallEval x) = object [ "tag" .= t "CallEval", "contents" .= toJSON x] - -t s = fromString s :: Text - -writeServer :: Comm -> ServerMsg -> STM () -writeServer c = writeComm c . toJSON . force - -{- Note [ServerMsg strictness] - -The type `ServerMsg` may contain components that evalute to _|_, and -an exception will be thrown when we try to send one of those to the browser. - -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 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 -------------------------------------------------------------------------------} --- | An event sent from the browser window to the server. -type Event = (Coupon, JSON.Value) - --- | An event handler that can be passed to the JavaScript client. -type HsEvent = RemotePtr (JSON.Value -> IO ()) - -quit :: Event -quit = ("quit", JSON.Null) - --- | Specification of how JavaScript functions should be called. -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, or an exported Haskell function is called. - | FlushOften - -- ^ The same as 'BufferRun', but this mode indicates - -- 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 - --- | Action that the server will run when a browser window connects. -type EventLoop = Server -> RequestInfo -> Comm -> IO () -type RequestInfo = [Cookie] - --- | Representation of a browser window. -data Window = Window - { getServer :: Server - -- ^ Server that the browser window communicates with. - , getCookies :: [Cookie] - -- ^ Cookies that the browser window has sent to the server when connecting. - - , 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. - , debug :: String -> IO () - -- ^ Send a debug message to the JavaScript console. - , onDisconnect :: IO () -> IO () - -- ^ Register an action to be performed when the client disconnects. - , wRoot :: RemotePtr () - , wEventHandlers :: Vendor (JSON.Value -> IO ()) - , wJSObjects :: Vendor JSPtr - } - -newPartialWindow :: IO Window -newPartialWindow = do - ptr <- newRemotePtr "" () =<< newVendor - b1 <- newTVarIO id - b2 <- newTVarIO NoBuffering - let nop = const $ return () - 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 --- as long as the external JavaScript connection is alive. -root :: Window -> RemotePtr () -root = wRoot - -{----------------------------------------------------------------------------- - Marshalling -------------------------------------------------------------------------------} -newtype JSPtr = JSPtr { unsJSPtr :: Coupon } - --- | A mutable JavaScript object. -type JSObject = RemotePtr JSPtr - --- | A mutable JavaScript object that has just been created. --- This a dummy type used for additional type safety. -data NewJSObject = NewJSObject +{-# 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 +import Control.DeepSeq +import Data.Aeson as JSON +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS (hPutStrLn) +import Data.IORef +import Data.Map as Map +import Data.String +import Data.Text +import Data.Typeable +import Snap.Core (Cookie(..)) +import System.IO (stderr) + +import Foreign.RemotePtr + +{----------------------------------------------------------------------------- + Server Configuration -- Static +------------------------------------------------------------------------------} +-- 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. + +* @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. + +* @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. + +* @jsCallBufferMode :: CallBufferMode@ + + The initial 'CallBufferMode' to use for 'runFunction'. + It can be changed at any time with 'setCallBufferMode'. + +(For reasons of forward compatibility, the constructor is not exported.) + +-} +data Config = Config + { jsPort :: Maybe Int + , jsAddr :: Maybe ByteString + , jsCustomHTML :: Maybe FilePath + , jsStatic :: Maybe FilePath + , jsLog :: ByteString -> IO () + , jsWindowReloadOnDisconnect :: Bool + , jsCallBufferMode :: CallBufferMode + } + +defaultPort :: Int +defaultPort = 8023 + +defaultAddr :: ByteString +defaultAddr = "127.0.0.1" + +-- | Default configuration. +-- +-- Port from environment variable or @8023@, listening on @localhost@, +-- no custom HTML, no static directory, +-- logging to stderr, +-- do reload on disconnect, +-- __buffer FFI calls__. +defaultConfig :: Config +defaultConfig = Config + { jsPort = Nothing + , jsAddr = Nothing + , jsWindowReloadOnDisconnect = True + , jsCustomHTML = Nothing + , jsStatic = Nothing + , jsLog = BS.hPutStrLn stderr + , jsCallBufferMode = FlushOften + } + +{----------------------------------------------------------------------------- + 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 + , sLog :: ByteString -> IO () -- function for logging + } +type Filepaths = (Integer, Map ByteString (FilePath, MimeType)) +newFilepaths = (0, Map.empty) + +{----------------------------------------------------------------------------- + Communication channel +------------------------------------------------------------------------------} +-- | Bidirectional communication channel. +data Comm = Comm + { 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 () +writeComm c = STM.writeTQueue (commOut c) + +readComm :: Comm -> STM JSON.Value +readComm c = STM.readTQueue (commIn c) + +{----------------------------------------------------------------------------- + Communication protocol +------------------------------------------------------------------------------} +-- | Messages received from the JavaScript client. +data ClientMsg + = Event Coupon JSON.Value + | Result JSON.Value + | Exception String + | Quit + deriving (Eq, Show) + +instance FromJSON ClientMsg where + parseJSON (Object msg) = do + tag <- msg .: "tag" + case (tag :: Text) of + "Event" -> Event <$> (msg .: "name") <*> (msg .: "arguments") + "Result" -> Result <$> (msg .: "contents") + "Exception" -> Exception <$> (msg .: "contents") + "Quit" -> return Quit + +readClient :: Comm -> STM ClientMsg +readClient c = do + msg <- readComm c + case JSON.fromJSON msg of + Error s -> error $ "Foreign.JavaScript: Error parsing client message " ++ show s + Success x -> return x + +-- | Messages sent by the Haskell server. +data ServerMsg + = RunEval String + | CallEval String + | Debug String + | Timestamp + deriving (Eq,Show) + +instance NFData ServerMsg where + rnf (RunEval x) = rnf x + rnf (CallEval x) = rnf x + rnf (Debug x) = rnf x + rnf (Timestamp ) = () + +instance ToJSON ServerMsg where + toJSON (Debug x) = object [ "tag" .= t "Debug" , "contents" .= toJSON x] + toJSON (Timestamp ) = object [ "tag" .= t "Timestamp" ] + toJSON (RunEval x) = object [ "tag" .= t "RunEval" , "contents" .= toJSON x] + toJSON (CallEval x) = object [ "tag" .= t "CallEval", "contents" .= toJSON x] + +t s = fromString s :: Text + +writeServer :: Comm -> ServerMsg -> STM () +writeServer c = writeComm c . toJSON . force + +{- Note [ServerMsg strictness] + +The type `ServerMsg` may contain components that evalute to _|_, and +an exception will be thrown when we try to send one of those to the browser. + +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 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 +------------------------------------------------------------------------------} +-- | An event sent from the browser window to the server. +type Event = (Coupon, JSON.Value) + +-- | An event handler that can be passed to the JavaScript client. +type HsEvent = RemotePtr (JSON.Value -> IO ()) + +quit :: Event +quit = ("quit", JSON.Null) + +-- | Specification of how JavaScript functions should be called. +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, or an exported Haskell function is called. + | FlushOften + -- ^ The same as 'BufferRun', but this mode indicates + -- 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 + +-- | Action that the server will run when a browser window connects. +type EventLoop = Server -> RequestInfo -> Comm -> IO () +type RequestInfo = [Cookie] + +-- | Representation of a browser window. +data Window = Window + { getServer :: Server + -- ^ Server that the browser window communicates with. + , getCookies :: [Cookie] + -- ^ Cookies that the browser window has sent to the server when connecting. + + , 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. + , debug :: String -> IO () + -- ^ Send a debug message to the JavaScript console. + , onDisconnect :: IO () -> IO () + -- ^ Register an action to be performed when the client disconnects. + , wRoot :: RemotePtr () + , wEventHandlers :: Vendor (JSON.Value -> IO ()) + , wJSObjects :: Vendor JSPtr + } + +newPartialWindow :: IO Window +newPartialWindow = do + ptr <- newRemotePtr "" () =<< newVendor + b1 <- newTVarIO id + b2 <- newTVarIO NoBuffering + let nop = const $ return () + 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 +-- as long as the external JavaScript connection is alive. +root :: Window -> RemotePtr () +root = wRoot + +{----------------------------------------------------------------------------- + Marshalling +------------------------------------------------------------------------------} +newtype JSPtr = JSPtr { unsJSPtr :: Coupon } + +-- | A mutable JavaScript object. +type JSObject = RemotePtr JSPtr + +-- | A mutable JavaScript object that has just been created. +-- This a dummy type used for additional type safety. +data NewJSObject = NewJSObject diff --git a/src/Foreign/RemotePtr.hs b/src/Foreign/RemotePtr.hs --- a/src/Foreign/RemotePtr.hs +++ b/src/Foreign/RemotePtr.hs @@ -1,211 +1,211 @@ -{-# LANGUAGE RecordWildCards, CPP, ExistentialQuantification #-} -{-# LANGUAGE MagicHash, UnboxedTuples #-} -module Foreign.RemotePtr ( - -- * Synopsis - -- | Toolbox for managing remote objects in Haskell. - - -- * RemotePtr - RemotePtr, - withRemotePtr, addFinalizer, destroy, addReachable, clearReachable, - unprotectedGetCoupon, - - -- * Coupons and Vendors - Coupon, newCoupon, - Vendor, newVendor, lookup, - newRemotePtr, - ) where - -import Prelude hiding (lookup) -import Control.Monad -import Control.Concurrent -import qualified Data.Text as T -import qualified Data.Map as Map -import Data.Functor -import Data.IORef - -import System.IO.Unsafe (unsafePerformIO) -import System.Mem.Weak hiding (addFinalizer) -import qualified System.Mem.Weak as Weak - -import qualified GHC.Base as GHC -import qualified GHC.Weak as GHC -import qualified GHC.IORef as GHC -import qualified GHC.STRef as GHC - -#if CABAL -#if MIN_VERSION_base(4,6,0) -#else -atomicModifyIORef' = atomicModifyIORef -#endif -#endif - -mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value) -#if CABAL -#if MIN_VERSION_base(4,9,0) -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 #) -#else -mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> - case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) -#endif -#else -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 - -type Map = Map.Map - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} --- | A 'Coupon' is a unique identifier. --- --- It is a string of alphanumeric ASCII characters and it is intended to --- be sent to or received from a remote program. --- --- The data structure 'Vendor' associates 'Coupon's to 'RemotPtr' objects. -type Coupon = T.Text - - --- | A 'RemotePtr' is a pointer to a foreign object. --- --- Like a 'ForeignPtr', it refers to an object managed by an environment --- external to the Haskell runtime. --- Likewise, you can assign finalizers to a 'RemotePtr'. The finalizers --- will be run when the Haskell runtime garbage collects this value. --- They can perform some cleanup operations, like freeing memory. --- --- Unlike a 'ForeignPtr', the object referenced by a 'RemotePtr' is not --- necessarily a block of RAM. Instead, it can refer to things like an object --- managed by a remote program. - -type RemotePtr a = IORef (RemoteData a) - -data RemoteData a = RemoteData - { self :: Weak (RemotePtr a) - , coupon :: Coupon - , value :: a - , children :: IORef [SomeWeak] - } - --- Existentially quantified weak pointer. We only care about its finalizer. -data SomeWeak = forall a. SomeWeak (Weak a) - --- | A 'Vendor' is a bijective mapping from 'Coupon' to 'RemotePtr'. --- --- Every 'Coupon' has at most one 'RemotePtr' associated to it. --- A single 'RemotePtr' will always be associated with the same 'Coupon'. - -data Vendor a = Vendor - { coupons :: MVar (Map Coupon (Weak (RemotePtr a))) - , counter :: MVar [Integer] - } - -{----------------------------------------------------------------------------- - Vendor and Coupons -------------------------------------------------------------------------------} --- | Create a new 'Vendor' for trading 'Coupon's and 'RemotePtr's. -newVendor :: IO (Vendor a) -newVendor = do - counter <- newMVar [0..] - coupons <- newMVar Map.empty - return $ Vendor {..} - --- | Take a 'Coupon' to a 'Vendor' and maybe you'll get a 'RemotePtr' for it. -lookup :: Coupon -> Vendor a -> IO (Maybe (RemotePtr a)) -lookup coupon Vendor{..} = do - w <- Map.lookup coupon <$> readMVar coupons - maybe (return Nothing) deRefWeak w - --- | Create a new 'Coupon'. --- --- WARNING: This coupon is only unique relative to this 'Vendor'. --- There is no guarantee that this 'Coupon' is globally unique, --- certainly not on a remote machine. -newCoupon :: Vendor a -> IO Coupon -newCoupon Vendor{..} = - T.pack . show <$> modifyMVar counter (\(n:ns) -> return (ns,n)) - --- | Create a new 'RemotePtr' from a 'Coupon' and register it with a 'Vendor'. -newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a) -newRemotePtr coupon value Vendor{..} = do - children <- newIORef [] - let self = undefined - ptr <- newIORef RemoteData{..} - - let finalize = modifyMVar coupons $ \m -> return (Map.delete coupon m, ()) - w <- mkWeakIORef ptr finalize - modifyMVar coupons $ \m -> return (Map.insert coupon w m, ()) - atomicModifyIORef' ptr $ \itemdata -> (itemdata { self = w }, ()) - return ptr - -{----------------------------------------------------------------------------- - RemotePtr -------------------------------------------------------------------------------} --- | Access the data of the 'RemotePtr'. --- --- While the action is being performed, it is ensured that the 'RemotePtr' --- will not be garbage collected --- and its 'Coupon' can be successfully redeemed at the 'Vendor'. -withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b -withRemotePtr ptr f = do - RemoteData{..} <- readIORef ptr - b <- f coupon value - touch ptr - return b - where - -- make sure that the pointer is alive at this point in the code - touch ptr = void $ readIORef ptr - --- | Unprotected access the 'Coupon' of a 'RemotePtr'. --- --- Note: There is no guarantee that the 'RemotePtr' is alive --- after this operation and that the 'Coupon' can be redeemed at a 'Vendor'. --- Most of the time, you should use 'withRemotePtr' instead. --- --- Note: In particular, if you use this with @unsafePerformIO@, --- the risk is high that you only refer to the 'RemotePtr' argument via --- the result just obtained, and the pointer will be garbage collected. -unprotectedGetCoupon :: RemotePtr a -> IO Coupon -unprotectedGetCoupon ptr = coupon <$> readIORef ptr - - --- | Add a finalizer that is run when the 'RemotePtr' is garbage collected. --- --- The associated coupon cannot be redeemed anymore while the finalizer runs. -addFinalizer :: RemotePtr a -> IO () -> IO () -addFinalizer ptr = void . mkWeakIORef ptr --- | FIXME: Is this finalizer really run when 'destroy' is called? - --- | Destroy a 'RemotePtr' and run all finalizers for it. --- 'Coupon's for this pointer can no longer be redeemed. -destroy :: RemotePtr a -> IO () -destroy ptr = finalize =<< self <$> readIORef ptr - - --- | When dealing with several foreign objects, --- it is useful to model dependencies between them. --- --- After this operation, the second 'RemotePtr' will be reachable --- whenever the first one is reachable. --- For instance, you should call this function when the second foreign object --- is actually a subobject of the first one. --- --- Note: It is possible to model dependencies in the @parent@ data, --- but the 'addReachable' method is preferrable, --- as it allows all child object to be garbage collected at once. -addReachable :: RemotePtr a -> RemotePtr b -> IO () -addReachable parent child = do - w <- mkWeakIORefValue parent child $ return () - ref <- children <$> readIORef parent - atomicModifyIORef' ref $ \ws -> (SomeWeak w:ws, ()) - --- | Clear all dependencies. --- --- Reachability of this 'RemotePtr' no longer implies reachability --- of other items, as formerly implied by calls to 'addReachable'. -clearReachable :: RemotePtr a -> IO () -clearReachable parent = do - ref <- children <$> readIORef parent - xs <- atomicModifyIORef' ref $ \xs -> ([], xs) - sequence_ [finalize x | SomeWeak x <- xs] +{-# LANGUAGE RecordWildCards, CPP, ExistentialQuantification #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Foreign.RemotePtr ( + -- * Synopsis + -- | Toolbox for managing remote objects in Haskell. + + -- * RemotePtr + RemotePtr, + withRemotePtr, addFinalizer, destroy, addReachable, clearReachable, + unprotectedGetCoupon, + + -- * Coupons and Vendors + Coupon, newCoupon, + Vendor, newVendor, lookup, + newRemotePtr, + ) where + +import Prelude hiding (lookup) +import Control.Monad +import Control.Concurrent +import qualified Data.Text as T +import qualified Data.Map as Map +import Data.Functor +import Data.IORef + +import System.IO.Unsafe (unsafePerformIO) +import System.Mem.Weak hiding (addFinalizer) +import qualified System.Mem.Weak as Weak + +import qualified GHC.Base as GHC +import qualified GHC.Weak as GHC +import qualified GHC.IORef as GHC +import qualified GHC.STRef as GHC + +#if CABAL +#if MIN_VERSION_base(4,6,0) +#else +atomicModifyIORef' = atomicModifyIORef +#endif +#endif + +mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value) +#if CABAL +#if MIN_VERSION_base(4,9,0) +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 #) +#else +mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> + case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) +#endif +#else +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 + +type Map = Map.Map + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} +-- | A 'Coupon' is a unique identifier. +-- +-- It is a string of alphanumeric ASCII characters and it is intended to +-- be sent to or received from a remote program. +-- +-- The data structure 'Vendor' associates 'Coupon's to 'RemotPtr' objects. +type Coupon = T.Text + + +-- | A 'RemotePtr' is a pointer to a foreign object. +-- +-- Like a 'ForeignPtr', it refers to an object managed by an environment +-- external to the Haskell runtime. +-- Likewise, you can assign finalizers to a 'RemotePtr'. The finalizers +-- will be run when the Haskell runtime garbage collects this value. +-- They can perform some cleanup operations, like freeing memory. +-- +-- Unlike a 'ForeignPtr', the object referenced by a 'RemotePtr' is not +-- necessarily a block of RAM. Instead, it can refer to things like an object +-- managed by a remote program. + +type RemotePtr a = IORef (RemoteData a) + +data RemoteData a = RemoteData + { self :: Weak (RemotePtr a) + , coupon :: Coupon + , value :: a + , children :: IORef [SomeWeak] + } + +-- Existentially quantified weak pointer. We only care about its finalizer. +data SomeWeak = forall a. SomeWeak (Weak a) + +-- | A 'Vendor' is a bijective mapping from 'Coupon' to 'RemotePtr'. +-- +-- Every 'Coupon' has at most one 'RemotePtr' associated to it. +-- A single 'RemotePtr' will always be associated with the same 'Coupon'. + +data Vendor a = Vendor + { coupons :: MVar (Map Coupon (Weak (RemotePtr a))) + , counter :: MVar [Integer] + } + +{----------------------------------------------------------------------------- + Vendor and Coupons +------------------------------------------------------------------------------} +-- | Create a new 'Vendor' for trading 'Coupon's and 'RemotePtr's. +newVendor :: IO (Vendor a) +newVendor = do + counter <- newMVar [0..] + coupons <- newMVar Map.empty + return $ Vendor {..} + +-- | Take a 'Coupon' to a 'Vendor' and maybe you'll get a 'RemotePtr' for it. +lookup :: Coupon -> Vendor a -> IO (Maybe (RemotePtr a)) +lookup coupon Vendor{..} = do + w <- Map.lookup coupon <$> readMVar coupons + maybe (return Nothing) deRefWeak w + +-- | Create a new 'Coupon'. +-- +-- WARNING: This coupon is only unique relative to this 'Vendor'. +-- There is no guarantee that this 'Coupon' is globally unique, +-- certainly not on a remote machine. +newCoupon :: Vendor a -> IO Coupon +newCoupon Vendor{..} = + T.pack . show <$> modifyMVar counter (\(n:ns) -> return (ns,n)) + +-- | Create a new 'RemotePtr' from a 'Coupon' and register it with a 'Vendor'. +newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a) +newRemotePtr coupon value Vendor{..} = do + children <- newIORef [] + let self = undefined + ptr <- newIORef RemoteData{..} + + let finalize = modifyMVar coupons $ \m -> return (Map.delete coupon m, ()) + w <- mkWeakIORef ptr finalize + modifyMVar coupons $ \m -> return (Map.insert coupon w m, ()) + atomicModifyIORef' ptr $ \itemdata -> (itemdata { self = w }, ()) + return ptr + +{----------------------------------------------------------------------------- + RemotePtr +------------------------------------------------------------------------------} +-- | Access the data of the 'RemotePtr'. +-- +-- While the action is being performed, it is ensured that the 'RemotePtr' +-- will not be garbage collected +-- and its 'Coupon' can be successfully redeemed at the 'Vendor'. +withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b +withRemotePtr ptr f = do + RemoteData{..} <- readIORef ptr + b <- f coupon value + touch ptr + return b + where + -- make sure that the pointer is alive at this point in the code + touch ptr = void $ readIORef ptr + +-- | Unprotected access the 'Coupon' of a 'RemotePtr'. +-- +-- Note: There is no guarantee that the 'RemotePtr' is alive +-- after this operation and that the 'Coupon' can be redeemed at a 'Vendor'. +-- Most of the time, you should use 'withRemotePtr' instead. +-- +-- Note: In particular, if you use this with @unsafePerformIO@, +-- the risk is high that you only refer to the 'RemotePtr' argument via +-- the result just obtained, and the pointer will be garbage collected. +unprotectedGetCoupon :: RemotePtr a -> IO Coupon +unprotectedGetCoupon ptr = coupon <$> readIORef ptr + + +-- | Add a finalizer that is run when the 'RemotePtr' is garbage collected. +-- +-- The associated coupon cannot be redeemed anymore while the finalizer runs. +addFinalizer :: RemotePtr a -> IO () -> IO () +addFinalizer ptr = void . mkWeakIORef ptr +-- | FIXME: Is this finalizer really run when 'destroy' is called? + +-- | Destroy a 'RemotePtr' and run all finalizers for it. +-- 'Coupon's for this pointer can no longer be redeemed. +destroy :: RemotePtr a -> IO () +destroy ptr = finalize =<< self <$> readIORef ptr + + +-- | When dealing with several foreign objects, +-- it is useful to model dependencies between them. +-- +-- After this operation, the second 'RemotePtr' will be reachable +-- whenever the first one is reachable. +-- For instance, you should call this function when the second foreign object +-- is actually a subobject of the first one. +-- +-- Note: It is possible to model dependencies in the @parent@ data, +-- but the 'addReachable' method is preferrable, +-- as it allows all child object to be garbage collected at once. +addReachable :: RemotePtr a -> RemotePtr b -> IO () +addReachable parent child = do + w <- mkWeakIORefValue parent child $ return () + ref <- children <$> readIORef parent + atomicModifyIORef' ref $ \ws -> (SomeWeak w:ws, ()) + +-- | Clear all dependencies. +-- +-- Reachability of this 'RemotePtr' no longer implies reachability +-- of other items, as formerly implied by calls to 'addReachable'. +clearReachable :: RemotePtr a -> IO () +clearReachable parent = do + ref <- children <$> readIORef parent + xs <- atomicModifyIORef' ref $ \xs -> ([], xs) + sequence_ [finalize x | SomeWeak x <- xs] diff --git a/src/Graphics/UI/Threepenny.hs b/src/Graphics/UI/Threepenny.hs --- a/src/Graphics/UI/Threepenny.hs +++ b/src/Graphics/UI/Threepenny.hs @@ -1,107 +1,107 @@ -module Graphics.UI.Threepenny ( - -- * Introduction - -- $intro - - -- * Example - -- $example - - -- * Modules - module Graphics.UI.Threepenny.Attributes, - module Graphics.UI.Threepenny.Core, - module Graphics.UI.Threepenny.Canvas, - module Graphics.UI.Threepenny.DragNDrop, - module Graphics.UI.Threepenny.Elements, - module Graphics.UI.Threepenny.Events, - module Graphics.UI.Threepenny.JQuery, - module Graphics.UI.Threepenny.Timer, - module Graphics.UI.Threepenny.Widgets, - ) where - -import Graphics.UI.Threepenny.Attributes -import Graphics.UI.Threepenny.Canvas -import Graphics.UI.Threepenny.Core -import Graphics.UI.Threepenny.DragNDrop -import Graphics.UI.Threepenny.Elements -import Graphics.UI.Threepenny.Events -import Graphics.UI.Threepenny.JQuery -import Graphics.UI.Threepenny.Timer -import Graphics.UI.Threepenny.Widgets - -{- $intro - -Welcome to the Threepenny library for graphical user interfaces. - -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. - -For an introduction, see the example below. -The module "Graphics.UI.Threepenny.Core" contains the main functions. - --} - - -{- $example - -The following example should help to get you started with Threepenny. -(The lines of code below are meant to be concatenated into a single file.) - -> module Main where - -First, we have to import the library. -It is a good idea to import the core module verbatim -and import all other functions with a mandatory @UI@ prefix. - -> import qualified Graphics.UI.Threepenny as UI -> import Graphics.UI.Threepenny.Core - -We begin by starting a server on port @8023@ using the 'startGUI' function. -Additional static content is served from the @../wwwroot@ directory. - -> main :: IO () -> main = do -> startGUI defaultConfig -> { jsPort = Just 8023 -> , jsStatic = Just "../wwwroot" -> } setup - -Whenever a browser connects to the server, -the following function will be executed to start the GUI interaction. -It builds the initial HTML page. - -> setup :: Window -> UI () -> setup window = do - -First, set the title of the HTML document - -> return window # set UI.title "Hello World!" - -Then create a button element - -> button <- UI.button # set UI.text "Click me!" - -DOM elements can be accessed much in the same way they are -accessed from JavaScript; they can be searched, updated, moved and -inspected. In the line above, we set the 'text' contents. - -To actually display the button, we have to attach it to the body of the HTML element. -The '#+' combinator allows you to nest elements quickly -in the style of a HTML combinator library. - -> getBody window #+ [element button] - -Finally, we register an event handler for the 'click' event, -which occurs whenever the user clicks on the button. -When that happens, we change the text of the button. - -> on UI.click button $ const $ do -> element button # set UI.text "I have been clicked!" - -That's it! Now, run the program and visit the URL -in your browser to interact with the user interface. - -The library comes with a -. - - --} - +module Graphics.UI.Threepenny ( + -- * Introduction + -- $intro + + -- * Example + -- $example + + -- * Modules + module Graphics.UI.Threepenny.Attributes, + module Graphics.UI.Threepenny.Core, + module Graphics.UI.Threepenny.Canvas, + module Graphics.UI.Threepenny.DragNDrop, + module Graphics.UI.Threepenny.Elements, + module Graphics.UI.Threepenny.Events, + module Graphics.UI.Threepenny.JQuery, + module Graphics.UI.Threepenny.Timer, + module Graphics.UI.Threepenny.Widgets, + ) where + +import Graphics.UI.Threepenny.Attributes +import Graphics.UI.Threepenny.Canvas +import Graphics.UI.Threepenny.Core +import Graphics.UI.Threepenny.DragNDrop +import Graphics.UI.Threepenny.Elements +import Graphics.UI.Threepenny.Events +import Graphics.UI.Threepenny.JQuery +import Graphics.UI.Threepenny.Timer +import Graphics.UI.Threepenny.Widgets + +{- $intro + +Welcome to the Threepenny library for graphical user interfaces. + +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. + +For an introduction, see the example below. +The module "Graphics.UI.Threepenny.Core" contains the main functions. + +-} + + +{- $example + +The following example should help to get you started with Threepenny. +(The lines of code below are meant to be concatenated into a single file.) + +> module Main where + +First, we have to import the library. +It is a good idea to import the core module verbatim +and import all other functions with a mandatory @UI@ prefix. + +> import qualified Graphics.UI.Threepenny as UI +> import Graphics.UI.Threepenny.Core + +We begin by starting a server on port @8023@ using the 'startGUI' function. +Additional static content is served from the @../wwwroot@ directory. + +> main :: IO () +> main = do +> startGUI defaultConfig +> { jsPort = Just 8023 +> , jsStatic = Just "../wwwroot" +> } setup + +Whenever a browser connects to the server, +the following function will be executed to start the GUI interaction. +It builds the initial HTML page. + +> setup :: Window -> UI () +> setup window = do + +First, set the title of the HTML document + +> return window # set UI.title "Hello World!" + +Then create a button element + +> button <- UI.button # set UI.text "Click me!" + +DOM elements can be accessed much in the same way they are +accessed from JavaScript; they can be searched, updated, moved and +inspected. In the line above, we set the 'text' contents. + +To actually display the button, we have to attach it to the body of the HTML element. +The '#+' combinator allows you to nest elements quickly +in the style of a HTML combinator library. + +> getBody window #+ [element button] + +Finally, we register an event handler for the 'click' event, +which occurs whenever the user clicks on the button. +When that happens, we change the text of the button. + +> on UI.click button $ const $ do +> element button # set UI.text "I have been clicked!" + +That's it! Now, run the program and visit the URL +in your browser to interact with the user interface. + +The library comes with a +. + + +-} + diff --git a/src/Graphics/UI/Threepenny/Attributes.hs b/src/Graphics/UI/Threepenny/Attributes.hs --- a/src/Graphics/UI/Threepenny/Attributes.hs +++ b/src/Graphics/UI/Threepenny/Attributes.hs @@ -1,128 +1,128 @@ -module Graphics.UI.Threepenny.Attributes ( - -- * Synopsis - -- | Element attributes. - - -- * Input elements - checked, selection, enabled, - - -- * HTML attributes - action, align, alink, alt, altcode, archive, - background, base, bgcolor, border, bordercolor, - cellpadding, cellspacing, checked_, class_, clear_, code_, codebase, - color, cols, colspan, compact, content, coords, - enctype, face, for, frameborder, height, href, hspace, httpequiv, - id_, ismap, lang, marginheight, marginwidth, maxlength, method, multiple, - name, nohref, noresize, noshade, nowrap, - rel, rev, rows, rowspan, rules, - scrolling, selected, shape, size, src, - target, text_, title__, type_, usemap, valign, version, vlink, vspace, width, - ) where - -import qualified Data.Aeson as JSON -import Graphics.UI.Threepenny.Core - -{----------------------------------------------------------------------------- - Attributes -------------------------------------------------------------------------------} --- | The @checked@ status of an input element of type checkbox. -checked :: Attr Element Bool -checked = fromJQueryProp "checked" (== JSON.Bool True) JSON.Bool - --- | The @enabled@ status of an input element -enabled :: Attr Element Bool -enabled = fromJQueryProp "disabled" (== JSON.Bool False) (JSON.Bool . not) - --- | Index of the currently selected option of a @@ element. +-- +-- The index starts at @0@. +-- If no option is selected, then the selection is 'Nothing'. +selection :: Attr Element (Maybe Int) +selection = fromJQueryProp "selectedIndex" from (JSON.toJSON . maybe (-1) id) + where + from s = let JSON.Success x = JSON.fromJSON s in + if x == -1 then Nothing else Just x + + +{----------------------------------------------------------------------------- + HTML atributes + + Taken from the HTML library (BSD3 license) + http://hackage.haskell.org/package/html +------------------------------------------------------------------------------} +strAttr :: String -> WriteAttr Element String +strAttr name = mkWriteAttr (set' (attr name)) + +intAttr :: String -> WriteAttr Element Int +intAttr name = mkWriteAttr (set' (attr name) . show) + +emptyAttr :: String -> WriteAttr Element Bool +emptyAttr name = mkWriteAttr (set' (attr name) . f) + where + f True = "1" + f False = "0" + +action = strAttr "action" +align = strAttr "align" +alink = strAttr "alink" +alt = strAttr "alt" +altcode = strAttr "altcode" +archive = strAttr "archive" +background = strAttr "background" +base = strAttr "base" +bgcolor = strAttr "bgcolor" +border = intAttr "border" +bordercolor = strAttr "bordercolor" +cellpadding = intAttr "cellpadding" +cellspacing = intAttr "cellspacing" +checked_ = emptyAttr "checked" +clear_ = strAttr "clear" +code_ = strAttr "code" +codebase = strAttr "codebase" +color = strAttr "color" +cols = strAttr "cols" +colspan = intAttr "colspan" +compact = emptyAttr "compact" +content = strAttr "content" +coords = strAttr "coords" +enctype = strAttr "enctype" +face = strAttr "face" +for = strAttr "for" +frameborder = intAttr "frameborder" +height = intAttr "height" +href = strAttr "href" +hspace = intAttr "hspace" +httpequiv = strAttr "http-equiv" +id_ = strAttr "id" +ismap = emptyAttr "ismap" +lang = strAttr "lang" +marginheight = intAttr "marginheight" +marginwidth = intAttr "marginwidth" +maxlength = intAttr "maxlength" +method = strAttr "method" +multiple = emptyAttr "multiple" +name = strAttr "name" +nohref = emptyAttr "nohref" +noresize = emptyAttr "noresize" +noshade = emptyAttr "noshade" +nowrap = emptyAttr "nowrap" +rel = strAttr "rel" +rev = strAttr "rev" +rows = strAttr "rows" +rowspan = intAttr "rowspan" +rules = strAttr "rules" +scrolling = strAttr "scrolling" +selected = emptyAttr "selected" +shape = strAttr "shape" +size = strAttr "size" +src = strAttr "src" +target = strAttr "target" +text_ = strAttr "text" +class_ = strAttr "class" +type_ = strAttr "type" +title__ = strAttr "title" -- ugly, but necessary to avoid conflicts with the window title and the title element +usemap = strAttr "usemap" +valign = strAttr "valign" +version = strAttr "version" +vlink = strAttr "vlink" +vspace = intAttr "vspace" +width = intAttr "width" diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs --- a/src/Graphics/UI/Threepenny/Canvas.hs +++ b/src/Graphics/UI/Threepenny/Canvas.hs @@ -1,270 +1,270 @@ -module Graphics.UI.Threepenny.Canvas ( - -- * Synopsis - -- | Partial binding to the HTML5 canvas API. - - -- * Documentation - Canvas - , Vector, Point - , Color(..), ColorStop, Gradient, FillStyle - , drawImage, clearCanvas - , solidColor, htmlColor - , linearGradient, horizontalLinearGradient, verticalLinearGradient - , fillRect, fillStyle, strokeStyle, lineWidth, textFont - , TextAlign(..), textAlign - , beginPath, moveTo, lineTo, closePath, arc, arc' - , fill, stroke, fillText, strokeText - ) where - -import Data.Char (toUpper) -import Data.List(intercalate) -import Numeric (showHex) - -import Graphics.UI.Threepenny.Core -import qualified Data.Aeson as JSON - -{----------------------------------------------------------------------------- - Canvas -------------------------------------------------------------------------------} -type Canvas = Element - -type Vector = Point -type Point = (Double, Double) -data Color = RGB { red :: Int, green :: Int, blue :: Int } - | RGBA { red :: Int, green :: Int, blue :: Int, alpha :: Double } - deriving (Eq, Show) - -type ColorStop = (Double, Color) - -data Gradient - -- | defines a linear gradient - -- see - = LinearGradient - { upperLeft :: Vector -- ^ the left-upper point where the gradient should begin - , gradWidth :: Double -- ^ the width of the gradient - , gradHeight :: Double -- ^ the height of the gradient - , colorStops :: [ColorStop] -- ^ the gradients color stops - } deriving (Show, Eq) - -data FillStyle - = SolidColor Color - | HtmlColor String -- Html representation of a color - | Gradient Gradient - deriving (Show, Eq) - - -{----------------------------------------------------------------------------- - Image drawing -------------------------------------------------------------------------------} - --- | Draw the image of an image element onto the canvas at a specified position. -drawImage :: Element -> Vector -> Canvas -> UI () -drawImage image (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').drawImage(%2,%3,%4)" canvas image x y - -{----------------------------------------------------------------------------- - Fill Styles -------------------------------------------------------------------------------} - --- | creates a solid-color fillstyle -solidColor :: Color -> FillStyle -solidColor rgb = SolidColor rgb - --- | Solid color represented as a HTML string. -htmlColor :: String -> FillStyle -htmlColor = HtmlColor - --- | creates a linear gradient fill style -linearGradient :: Point -- ^ The upper-left coordinate of the gradient - -> Double -- ^ The width of the gradient - -> Double -- ^ The height of the gradient - -> [ColorStop] -- ^ the color-stops for the gradient - -> FillStyle -linearGradient (x0, y0) w h sts = Gradient $ LinearGradient (x0,y0) w h sts - --- | creates a simple horizontal gradient -horizontalLinearGradient:: Point -- ^ The upper-left coordinate of the gradient - -> Double -- ^ The width of the gradient - -> Color -- ^ The starting color of the gradient - -> Color -- ^ The ending color of the gradient - -> FillStyle -horizontalLinearGradient pt w c0 c1 = linearGradient pt w 0 [(0, c0), (1, c1)] - --- | creates a simple vertical gradient -verticalLinearGradient:: Point -- ^ The upper-left coordinate of the gradient - -> Double -- ^ The height of the gradient - -> Color -- ^ The starting color of the gradient - -> Color -- ^ The ending color of the gradient - -> FillStyle -verticalLinearGradient pt h c0 c1 = linearGradient pt 0 h [(0, c0), (1, c1)] - -{----------------------------------------------------------------------------- - general -------------------------------------------------------------------------------} - --- | Clear the canvas -clearCanvas :: Canvas -> UI () -clearCanvas = runFunction . ffi "%1.getContext('2d').clear()" - - -{----------------------------------------------------------------------------- - fill primitives -------------------------------------------------------------------------------} - - --- | Draw a filled rectangle. --- --- The 'fillStyle' attribute determines the color. -fillRect - :: Point -- ^ upper left corner - -> Double -- ^ width in pixels - -> Double -- ^ height in pixels - -> Canvas -> UI () -fillRect (x,y) w h canvas = - runFunction $ ffi "%1.getContext('2d').fillRect(%2, %3, %4, %5)" canvas x y w h - --- | The Fillstyle to use inside shapes. --- write-only as I could not find how to consistently read the fillstyle -fillStyle :: WriteAttr Canvas FillStyle -fillStyle = mkWriteAttr assignFillStyle - --- | sets the current fill style of the canvas context -assignFillStyle :: FillStyle -> Canvas -> UI () -assignFillStyle (Gradient fs) canvas = - runFunction $ ffi cmd canvas - where cmd = "var ctx=%1.getContext('2d'); var grd=" ++ fsStr fs ++ cStops fs ++ "ctx.fillStyle=grd;" - fsStr (LinearGradient (x0, y0) w h _) - = "ctx.createLinearGradient(" ++ pStr [x0, y0, x0+w, y0+h] ++ ");" - cStops (LinearGradient _ _ _ sts) = concatMap addStop sts - addStop (p,c) = "grd.addColorStop(" ++ show p ++ ",'" ++ rgbString c ++ "');" - pStr = intercalate "," . map show -assignFillStyle (SolidColor color) canvas = - runFunction $ ffi "%1.getContext('2d').fillStyle=%2" canvas (rgbString color) -assignFillStyle (HtmlColor color) canvas = - runFunction $ ffi "%1.getContext('2d').fillStyle=%2" canvas color - --- | The color or style to use for the lines around shapes. --- Default is @#000@ (black). -strokeStyle :: Attr Canvas String -strokeStyle = fromObjectProperty "getContext('2d').strokeStyle" - --- | The width of lines. Default is @1@. -lineWidth :: Attr Canvas Double -lineWidth = fromObjectProperty "getContext('2d').lineWidth" - --- | The font used for 'fillText' and 'strokeText'. --- Default is @10px sans-serif@. -textFont :: Attr Canvas String -textFont = fromObjectProperty "getContext('2d').font" - -data TextAlign = Start | End | LeftAligned | RightAligned | Center - deriving (Eq, Show, Read) - -aToS :: TextAlign -> String -aToS algn = - case algn of - Start -> "start" - End -> "end" - LeftAligned -> "left" - RightAligned -> "right" - Center -> "center" - -sToA :: String -> TextAlign -sToA algn = - case algn of - "start" -> Start - "end" -> End - "left" -> LeftAligned - "right" -> RightAligned - "center" -> Center - _ -> Start - --- | The alignment for 'fillText' and 'strokeText'. Default is 'Start'. -textAlign :: Attr Canvas TextAlign -textAlign = bimapAttr aToS sToA $ textAlignStr - where - textAlignStr :: Attr Canvas String - textAlignStr = fromObjectProperty "getContext('2d').textAlign" - --- | Starts a new path by resetting the list of sub-paths. --- Call this function when you want to create a new path. -beginPath :: Canvas -> UI() -beginPath = runFunction . ffi "%1.getContext('2d').beginPath()" - --- | Moves the starting point of a new subpath to the @(x,y)@ coordinate. -moveTo :: Point -> Canvas -> UI() -moveTo (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').moveTo(%2, %3)" canvas x y - --- | Connects the last point in the subpath to the @(x,y)@ coordinates --- with a straight line. -lineTo :: Point -> Canvas -> UI() -lineTo (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').lineTo(%2, %3)" canvas x y - --- | Draw a straight line from the current point to the start of the --- path. If the shape has already been closed or has only one point, --- this function does nothing. -closePath :: Canvas -> UI() -closePath = runFunction . ffi "%1.getContext('2d').closePath()" - --- | Add a circular arc to the current path. -arc - :: Point -- ^ Center of the circle of which the arc is a part. - -> Double -- ^ Radius of the circle of which the arc is a part. - -> Double -- ^ Starting angle, in radians. - -> Double -- ^ Ending angle, in radians. - -> Canvas -> UI () -arc (x,y) radius startAngle endAngle canvas = - runFunction $ ffi "%1.getContext('2d').arc(%2, %3, %4, %5, %6)" - canvas x y radius startAngle endAngle - --- | Like 'arc', but with an extra argument that indicates whether --- we go in counter-clockwise ('True') or clockwise ('False') direction. -arc' :: Point -> Double -> Double -> Double -> Bool -> Canvas -> UI () -arc' (x,y) radius startAngle endAngle anti canvas = - runFunction $ ffi "%1.getContext('2d').arc(%2, %3, %4, %5, %6, %7)" - canvas x y radius startAngle endAngle anti - --- | Fills the subpaths with the current fill style. -fill :: Canvas -> UI () -fill = runFunction . ffi "%1.getContext('2d').fill()" - --- | Strokes the subpaths with the current stroke style. -stroke :: Canvas -> UI () -stroke = runFunction . ffi "%1.getContext('2d').stroke()" - --- | Render a text in solid color at a certain point on the canvas. --- --- The 'fillStyle' attribute determines the color. --- The 'textFont' attribute determines the font used. --- The 'textAlign' attributes determines the position of the text --- relative to the point. -fillText :: String -> Point -> Canvas -> UI () -fillText text (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas text x y - --- | Render the outline of a text at a certain point on the canvas. --- --- The 'strokeStyle' attribute determines the color of the outline. --- The 'textFont' attribute determines the font used. --- The 'textAlign' attributes determines the position of the text --- relative to the point. -strokeText :: String -> Point -> Canvas -> UI () -strokeText text (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas text x y - -{----------------------------------------------------------------------------- - helper functions -------------------------------------------------------------------------------} - -rgbString :: Color -> String -rgbString color = - case color of - (RGB r g b) -> "#" ++ sh r ++ sh g ++ sh b - (RGBA r g b a) -> "rgba(" ++ show r ++ "," ++ show g ++ "," ++ show b ++ "," ++ show a ++ ")" - where sh i = pad . map toUpper $ showHex i "" - pad s - | length s == 0 = "00" - | length s == 1 = '0' : s - | length s == 2 = s +module Graphics.UI.Threepenny.Canvas ( + -- * Synopsis + -- | Partial binding to the HTML5 canvas API. + + -- * Documentation + Canvas + , Vector, Point + , Color(..), ColorStop, Gradient, FillStyle + , drawImage, clearCanvas + , solidColor, htmlColor + , linearGradient, horizontalLinearGradient, verticalLinearGradient + , fillRect, fillStyle, strokeStyle, lineWidth, textFont + , TextAlign(..), textAlign + , beginPath, moveTo, lineTo, closePath, arc, arc' + , fill, stroke, fillText, strokeText + ) where + +import Data.Char (toUpper) +import Data.List(intercalate) +import Numeric (showHex) + +import Graphics.UI.Threepenny.Core +import qualified Data.Aeson as JSON + +{----------------------------------------------------------------------------- + Canvas +------------------------------------------------------------------------------} +type Canvas = Element + +type Vector = Point +type Point = (Double, Double) +data Color = RGB { red :: Int, green :: Int, blue :: Int } + | RGBA { red :: Int, green :: Int, blue :: Int, alpha :: Double } + deriving (Eq, Show) + +type ColorStop = (Double, Color) + +data Gradient + -- | defines a linear gradient + -- see + = LinearGradient + { upperLeft :: Vector -- ^ the left-upper point where the gradient should begin + , gradWidth :: Double -- ^ the width of the gradient + , gradHeight :: Double -- ^ the height of the gradient + , colorStops :: [ColorStop] -- ^ the gradients color stops + } deriving (Show, Eq) + +data FillStyle + = SolidColor Color + | HtmlColor String -- Html representation of a color + | Gradient Gradient + deriving (Show, Eq) + + +{----------------------------------------------------------------------------- + Image drawing +------------------------------------------------------------------------------} + +-- | Draw the image of an image element onto the canvas at a specified position. +drawImage :: Element -> Vector -> Canvas -> UI () +drawImage image (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').drawImage(%2,%3,%4)" canvas image x y + +{----------------------------------------------------------------------------- + Fill Styles +------------------------------------------------------------------------------} + +-- | creates a solid-color fillstyle +solidColor :: Color -> FillStyle +solidColor rgb = SolidColor rgb + +-- | Solid color represented as a HTML string. +htmlColor :: String -> FillStyle +htmlColor = HtmlColor + +-- | creates a linear gradient fill style +linearGradient :: Point -- ^ The upper-left coordinate of the gradient + -> Double -- ^ The width of the gradient + -> Double -- ^ The height of the gradient + -> [ColorStop] -- ^ the color-stops for the gradient + -> FillStyle +linearGradient (x0, y0) w h sts = Gradient $ LinearGradient (x0,y0) w h sts + +-- | creates a simple horizontal gradient +horizontalLinearGradient:: Point -- ^ The upper-left coordinate of the gradient + -> Double -- ^ The width of the gradient + -> Color -- ^ The starting color of the gradient + -> Color -- ^ The ending color of the gradient + -> FillStyle +horizontalLinearGradient pt w c0 c1 = linearGradient pt w 0 [(0, c0), (1, c1)] + +-- | creates a simple vertical gradient +verticalLinearGradient:: Point -- ^ The upper-left coordinate of the gradient + -> Double -- ^ The height of the gradient + -> Color -- ^ The starting color of the gradient + -> Color -- ^ The ending color of the gradient + -> FillStyle +verticalLinearGradient pt h c0 c1 = linearGradient pt 0 h [(0, c0), (1, c1)] + +{----------------------------------------------------------------------------- + general +------------------------------------------------------------------------------} + +-- | Clear the canvas +clearCanvas :: Canvas -> UI () +clearCanvas = runFunction . ffi "%1.getContext('2d').clear()" + + +{----------------------------------------------------------------------------- + fill primitives +------------------------------------------------------------------------------} + + +-- | Draw a filled rectangle. +-- +-- The 'fillStyle' attribute determines the color. +fillRect + :: Point -- ^ upper left corner + -> Double -- ^ width in pixels + -> Double -- ^ height in pixels + -> Canvas -> UI () +fillRect (x,y) w h canvas = + runFunction $ ffi "%1.getContext('2d').fillRect(%2, %3, %4, %5)" canvas x y w h + +-- | The Fillstyle to use inside shapes. +-- write-only as I could not find how to consistently read the fillstyle +fillStyle :: WriteAttr Canvas FillStyle +fillStyle = mkWriteAttr assignFillStyle + +-- | sets the current fill style of the canvas context +assignFillStyle :: FillStyle -> Canvas -> UI () +assignFillStyle (Gradient fs) canvas = + runFunction $ ffi cmd canvas + where cmd = "var ctx=%1.getContext('2d'); var grd=" ++ fsStr fs ++ cStops fs ++ "ctx.fillStyle=grd;" + fsStr (LinearGradient (x0, y0) w h _) + = "ctx.createLinearGradient(" ++ pStr [x0, y0, x0+w, y0+h] ++ ");" + cStops (LinearGradient _ _ _ sts) = concatMap addStop sts + addStop (p,c) = "grd.addColorStop(" ++ show p ++ ",'" ++ rgbString c ++ "');" + pStr = intercalate "," . map show +assignFillStyle (SolidColor color) canvas = + runFunction $ ffi "%1.getContext('2d').fillStyle=%2" canvas (rgbString color) +assignFillStyle (HtmlColor color) canvas = + runFunction $ ffi "%1.getContext('2d').fillStyle=%2" canvas color + +-- | The color or style to use for the lines around shapes. +-- Default is @#000@ (black). +strokeStyle :: Attr Canvas String +strokeStyle = fromObjectProperty "getContext('2d').strokeStyle" + +-- | The width of lines. Default is @1@. +lineWidth :: Attr Canvas Double +lineWidth = fromObjectProperty "getContext('2d').lineWidth" + +-- | The font used for 'fillText' and 'strokeText'. +-- Default is @10px sans-serif@. +textFont :: Attr Canvas String +textFont = fromObjectProperty "getContext('2d').font" + +data TextAlign = Start | End | LeftAligned | RightAligned | Center + deriving (Eq, Show, Read) + +aToS :: TextAlign -> String +aToS algn = + case algn of + Start -> "start" + End -> "end" + LeftAligned -> "left" + RightAligned -> "right" + Center -> "center" + +sToA :: String -> TextAlign +sToA algn = + case algn of + "start" -> Start + "end" -> End + "left" -> LeftAligned + "right" -> RightAligned + "center" -> Center + _ -> Start + +-- | The alignment for 'fillText' and 'strokeText'. Default is 'Start'. +textAlign :: Attr Canvas TextAlign +textAlign = bimapAttr aToS sToA $ textAlignStr + where + textAlignStr :: Attr Canvas String + textAlignStr = fromObjectProperty "getContext('2d').textAlign" + +-- | Starts a new path by resetting the list of sub-paths. +-- Call this function when you want to create a new path. +beginPath :: Canvas -> UI() +beginPath = runFunction . ffi "%1.getContext('2d').beginPath()" + +-- | Moves the starting point of a new subpath to the @(x,y)@ coordinate. +moveTo :: Point -> Canvas -> UI() +moveTo (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').moveTo(%2, %3)" canvas x y + +-- | Connects the last point in the subpath to the @(x,y)@ coordinates +-- with a straight line. +lineTo :: Point -> Canvas -> UI() +lineTo (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').lineTo(%2, %3)" canvas x y + +-- | Draw a straight line from the current point to the start of the +-- path. If the shape has already been closed or has only one point, +-- this function does nothing. +closePath :: Canvas -> UI() +closePath = runFunction . ffi "%1.getContext('2d').closePath()" + +-- | Add a circular arc to the current path. +arc + :: Point -- ^ Center of the circle of which the arc is a part. + -> Double -- ^ Radius of the circle of which the arc is a part. + -> Double -- ^ Starting angle, in radians. + -> Double -- ^ Ending angle, in radians. + -> Canvas -> UI () +arc (x,y) radius startAngle endAngle canvas = + runFunction $ ffi "%1.getContext('2d').arc(%2, %3, %4, %5, %6)" + canvas x y radius startAngle endAngle + +-- | Like 'arc', but with an extra argument that indicates whether +-- we go in counter-clockwise ('True') or clockwise ('False') direction. +arc' :: Point -> Double -> Double -> Double -> Bool -> Canvas -> UI () +arc' (x,y) radius startAngle endAngle anti canvas = + runFunction $ ffi "%1.getContext('2d').arc(%2, %3, %4, %5, %6, %7)" + canvas x y radius startAngle endAngle anti + +-- | Fills the subpaths with the current fill style. +fill :: Canvas -> UI () +fill = runFunction . ffi "%1.getContext('2d').fill()" + +-- | Strokes the subpaths with the current stroke style. +stroke :: Canvas -> UI () +stroke = runFunction . ffi "%1.getContext('2d').stroke()" + +-- | Render a text in solid color at a certain point on the canvas. +-- +-- The 'fillStyle' attribute determines the color. +-- The 'textFont' attribute determines the font used. +-- The 'textAlign' attributes determines the position of the text +-- relative to the point. +fillText :: String -> Point -> Canvas -> UI () +fillText text (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas text x y + +-- | Render the outline of a text at a certain point on the canvas. +-- +-- The 'strokeStyle' attribute determines the color of the outline. +-- The 'textFont' attribute determines the font used. +-- The 'textAlign' attributes determines the position of the text +-- relative to the point. +strokeText :: String -> Point -> Canvas -> UI () +strokeText text (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas text x y + +{----------------------------------------------------------------------------- + helper functions +------------------------------------------------------------------------------} + +rgbString :: Color -> String +rgbString color = + case color of + (RGB r g b) -> "#" ++ sh r ++ sh g ++ sh b + (RGBA r g b a) -> "rgba(" ++ show r ++ "," ++ show g ++ "," ++ show b ++ "," ++ show a ++ ")" + where sh i = pad . map toUpper $ showHex i "" + pad s + | length s == 0 = "00" + | length s == 1 = '0' : s + | length s == 2 = s | otherwise = take 2 s diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs --- a/src/Graphics/UI/Threepenny/Core.hs +++ b/src/Graphics/UI/Threepenny/Core.hs @@ -1,388 +1,388 @@ -{-# 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, 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, - string, - 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, - -- ** Internals - toJSObject, liftJSWindow, - -- * 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 -import qualified Reactive.Threepenny as Reactive - --- exports -import Foreign.JavaScript (Config(..), defaultConfig) -import Graphics.UI.Threepenny.Internal -import Reactive.Threepenny hiding (onChange) - - -{----------------------------------------------------------------------------- - Server -------------------------------------------------------------------------------} -{- $server - -To display the user interface, you have to start a server using 'startGUI'. -Then, visit the URL in your browser -(assuming that you use the default server configuration 'defaultConfig', -or have set the port number to @jsPort=Just 8023@.) - -The server is multithreaded. -FFI calls can be made concurrently, but events are handled sequentially. - -FFI calls can be __buffered__, -so in some circumstances, it may happen that you manipulate the browser window, -but the effect is not immediately visible. -See 'CallBufferMode' for more information. - --} - -{----------------------------------------------------------------------------- - Browser window -------------------------------------------------------------------------------} --- | Title of the client window. -title :: WriteAttr Window String -title = mkWriteAttr $ \s _ -> - runFunction $ ffi "document.title = %1;" s - -{----------------------------------------------------------------------------- - DOM Elements -------------------------------------------------------------------------------} --- | Append DOM elements as children to a given element. -(#+) :: UI Element -> [UI Element] -> UI Element -(#+) mx mys = do - x <- mx - ys <- sequence mys - mapM_ (Core.appendChild x) ys - return x - --- | Child elements of a given element. -children :: WriteAttr Element [Element] -children = mkWriteAttr set - where - set xs x = do - Core.clearChildren x - mapM_ (Core.appendChild x) xs - --- | Child elements of a given element as a HTML string. -html :: WriteAttr Element String -html = mkWriteAttr $ \s el -> - runFunction $ ffi "$(%1).html(%2)" el s - --- | HTML attributes of an element. -attr :: String -> WriteAttr Element String -attr name = mkWriteAttr $ \s el -> - runFunction $ ffi "$(%1).attr(%2,%3)" el name s - --- | Set CSS style of an Element -style :: WriteAttr Element [(String,String)] -style = mkWriteAttr $ \xs el -> forM_ xs $ \(name,val) -> - runFunction $ ffi "%1.style[%2] = %3" el name val - --- | Value attribute of an element. --- Particularly relevant for control widgets like 'input'. -value :: Attr Element String -value = mkReadWriteAttr get set - where - get el = callFunction $ ffi "$(%1).val()" el - set v el = runFunction $ ffi "$(%1).val(%2)" el v - --- | Text content of an element. -text :: WriteAttr Element String -text = mkWriteAttr $ \s el -> - runFunction $ ffi "$(%1).text(%2)" el s - --- | Make a @span@ element with a given text content. -string :: String -> UI Element -string s = mkElement "span" # set text s - --- | Get the head of the page. -getHead :: Window -> UI Element -getHead _ = fromJSObject =<< callFunction (ffi "document.head") - --- | Get the body of the page. -getBody :: Window -> UI Element -getBody _ = fromJSObject =<< callFunction (ffi "document.body") - --- | Get all elements of the given tag name. -getElementsByTagName - :: Window -- ^ Browser window - -> String -- ^ The tag name. - -> UI [Element] -- ^ All elements with that tag name. -getElementsByTagName _ tag = - mapM fromJSObject =<< callFunction (ffi "document.getElementsByTagName(%1)" tag) - --- | Get an element by a particular ID. -getElementById - :: Window -- ^ Browser window - -> String -- ^ The ID string. - -> UI (Maybe Element) -- ^ Element (if any) with given ID. -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 - :: Window -- ^ Browser window - -> String -- ^ The class string. - -> UI [Element] -- ^ Elements with given class. -getElementsByClassName window s = - mapM fromJSObject =<< callFunction (ffi "document.getElementsByClassName(%1)" s) - -{----------------------------------------------------------------------------- - Layout -------------------------------------------------------------------------------} --- | Align given elements in a row. Special case of 'grid'. -row :: [UI Element] -> UI Element -row xs = grid [xs] - --- | Align given elements in a column. Special case of 'grid'. -column :: [UI Element] -> UI Element -column = grid . map (:[]) - --- | Align given elements in a rectangular grid. --- --- Layout is achieved by using the CSS @display:table@ property. --- The following element tree will be generated --- --- >
--- >
--- >
...
--- >
...
--- >
--- >
--- > ... --- >
--- > ... --- >
--- --- You can customatize the actual layout by assigning an @id@ to the element --- and changing the @.table@, @.table-row@ and @table-column@ --- classes in a custom CSS file. -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] - wrap "table-row" row - wrap "table" rows - - where - wrap c xs = mkElement "div" # set (attr "class") c #+ map element xs - -{----------------------------------------------------------------------------- - Events -------------------------------------------------------------------------------} --- | Convenience function to register 'Event's for 'Element's. --- --- Example usage. --- --- > on click element $ \_ -> ... -on :: (element -> Event a) -> element -> (a -> UI void) -> UI () -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 - window <- askWindow - let flush = liftJSWindow $ \w -> do - mode <- JS.getCallBufferMode w - case mode of - FlushOften -> JS.flushCallBuffer w - _ -> return () - unregister <- liftIO $ register e (void . runUI window . (>> flush) . h) - return (liftIO unregister) - --- | Execute a 'UI' action whenever a 'Behavior' changes. --- Use sparingly, it is recommended that you use 'sink' instead. -onChanges :: Behavior a -> (a -> UI void) -> UI () -onChanges b f = do - window <- askWindow - liftIO $ Reactive.onChange b (void . runUI window . f) - -{----------------------------------------------------------------------------- - Attributes -------------------------------------------------------------------------------} -infixl 8 # -infixl 8 #+ -infixl 8 #. - --- | Reverse function application. --- Allows convenient notation for setting properties. --- --- Example usage. --- --- > mkElement "div" --- > # set style [("color","#CCAABB")] --- > # set draggable True --- > # set children otherElements -(#) :: a -> (a -> b) -> b -(#) = flip ($) - --- | Convenient combinator for setting the CSS class on element creation. -(#.) :: UI Element -> String -> UI Element -(#.) mx s = mx # set (attr "class") s - --- | Attributes can be 'set' and 'get'. -type Attr x a = ReadWriteAttr x a a - --- | Attribute that only supports the 'get' operation. -type ReadAttr x o = ReadWriteAttr x () o - --- | Attribute that only supports the 'set' operation. -type WriteAttr x i = ReadWriteAttr x i () - --- | Generalized attribute with different types for getting and setting. -data ReadWriteAttr x i o = ReadWriteAttr - { get' :: x -> UI o - , set' :: i -> x -> UI () - } - -instance Functor (ReadWriteAttr x i) where - fmap f = bimapAttr id f - --- | Map input and output type of an attribute. -bimapAttr :: (i' -> i) -> (o -> o') - -> ReadWriteAttr x i o -> ReadWriteAttr x i' o' -bimapAttr from to attr = attr - { get' = fmap to . get' attr - , set' = \i' -> set' attr (from i') - } - --- | Set value of an attribute in the 'UI' monad. --- Best used in conjunction with '#'. -set :: ReadWriteAttr x i o -> i -> UI x -> UI x -set attr i mx = do { x <- mx; set' attr i x; return x; } - --- | Set the value of an attribute to a 'Behavior', that is a time-varying value. --- --- Note: For reasons of efficiency, the attribute is only --- updated when the value changes. -sink :: ReadWriteAttr x i o -> Behavior i -> UI x -> UI x -sink attr bi mx = do - x <- mx - window <- askWindow - liftIOLater $ do - i <- currentValue bi - runUI window $ set' attr i x - Reactive.onChange bi $ \i -> runUI window $ set' attr i x - return x - --- | Get attribute value. -get :: ReadWriteAttr x i o -> x -> UI o -get attr = get' attr - --- | Build an attribute from a getter and a setter. -mkReadWriteAttr - :: (x -> UI o) -- ^ Getter. - -> (i -> x -> UI ()) -- ^ Setter. - -> ReadWriteAttr x i o -mkReadWriteAttr get set = ReadWriteAttr { get' = get, set' = set } - --- | Build attribute from a getter. -mkReadAttr :: (x -> UI o) -> ReadAttr x o -mkReadAttr get = mkReadWriteAttr get (\_ _ -> return ()) - --- | Build attribute from a setter. -mkWriteAttr :: (i -> x -> UI ()) -> WriteAttr x i -mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set - --- | Turn a jQuery property @.prop()@ into an attribute. -fromJQueryProp :: String -> (JSON.Value -> a) -> (a -> JSON.Value) -> Attr Element a -fromJQueryProp name from to = mkReadWriteAttr get set - where - set v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v) - get el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name - --- | Turn a JavaScript object property @.prop = ...@ into an attribute. -fromObjectProperty :: (FromJS a, ToJS a) => String -> Attr Element a -fromObjectProperty name = mkReadWriteAttr get set - where - set v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v - get el = callFunction $ ffi ("%1." ++ name) el - -{----------------------------------------------------------------------------- - Widget class -------------------------------------------------------------------------------} --- | Widgets are data types that have a visual representation. -class Widget w where - getElement :: w -> Element - -instance Widget Element where - getElement = id - --- | Convenience synonym for 'return' to make elements work well with 'set'. --- Also works on 'Widget's. --- --- Example usage. --- --- > e <- mkElement "button" --- > element e # set text "Ok" -element :: MonadIO m => Widget w => w -> m Element -element = return . getElement - --- | Convenience synonym for 'return' to make widgets work well with 'set'. -widget :: Widget w => w -> UI w -widget = return +{-# 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, 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, + string, + 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, + -- ** Internals + toJSObject, liftJSWindow, + -- * 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 +import qualified Reactive.Threepenny as Reactive + +-- exports +import Foreign.JavaScript (Config(..), defaultConfig) +import Graphics.UI.Threepenny.Internal +import Reactive.Threepenny hiding (onChange) + + +{----------------------------------------------------------------------------- + Server +------------------------------------------------------------------------------} +{- $server + +To display the user interface, you have to start a server using 'startGUI'. +Then, visit the URL in your browser +(assuming that you use the default server configuration 'defaultConfig', +or have set the port number to @jsPort=Just 8023@.) + +The server is multithreaded. +FFI calls can be made concurrently, but events are handled sequentially. + +FFI calls can be __buffered__, +so in some circumstances, it may happen that you manipulate the browser window, +but the effect is not immediately visible. +See 'CallBufferMode' for more information. + +-} + +{----------------------------------------------------------------------------- + Browser window +------------------------------------------------------------------------------} +-- | Title of the client window. +title :: WriteAttr Window String +title = mkWriteAttr $ \s _ -> + runFunction $ ffi "document.title = %1;" s + +{----------------------------------------------------------------------------- + DOM Elements +------------------------------------------------------------------------------} +-- | Append DOM elements as children to a given element. +(#+) :: UI Element -> [UI Element] -> UI Element +(#+) mx mys = do + x <- mx + ys <- sequence mys + mapM_ (Core.appendChild x) ys + return x + +-- | Child elements of a given element. +children :: WriteAttr Element [Element] +children = mkWriteAttr set + where + set xs x = do + Core.clearChildren x + mapM_ (Core.appendChild x) xs + +-- | Child elements of a given element as a HTML string. +html :: WriteAttr Element String +html = mkWriteAttr $ \s el -> + runFunction $ ffi "$(%1).html(%2)" el s + +-- | HTML attributes of an element. +attr :: String -> WriteAttr Element String +attr name = mkWriteAttr $ \s el -> + runFunction $ ffi "$(%1).attr(%2,%3)" el name s + +-- | Set CSS style of an Element +style :: WriteAttr Element [(String,String)] +style = mkWriteAttr $ \xs el -> forM_ xs $ \(name,val) -> + runFunction $ ffi "%1.style[%2] = %3" el name val + +-- | Value attribute of an element. +-- Particularly relevant for control widgets like 'input'. +value :: Attr Element String +value = mkReadWriteAttr get set + where + get el = callFunction $ ffi "$(%1).val()" el + set v el = runFunction $ ffi "$(%1).val(%2)" el v + +-- | Text content of an element. +text :: WriteAttr Element String +text = mkWriteAttr $ \s el -> + runFunction $ ffi "$(%1).text(%2)" el s + +-- | Make a @span@ element with a given text content. +string :: String -> UI Element +string s = mkElement "span" # set text s + +-- | Get the head of the page. +getHead :: Window -> UI Element +getHead _ = fromJSObject =<< callFunction (ffi "document.head") + +-- | Get the body of the page. +getBody :: Window -> UI Element +getBody _ = fromJSObject =<< callFunction (ffi "document.body") + +-- | Get all elements of the given tag name. +getElementsByTagName + :: Window -- ^ Browser window + -> String -- ^ The tag name. + -> UI [Element] -- ^ All elements with that tag name. +getElementsByTagName _ tag = + mapM fromJSObject =<< callFunction (ffi "document.getElementsByTagName(%1)" tag) + +-- | Get an element by a particular ID. +getElementById + :: Window -- ^ Browser window + -> String -- ^ The ID string. + -> UI (Maybe Element) -- ^ Element (if any) with given ID. +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 + :: Window -- ^ Browser window + -> String -- ^ The class string. + -> UI [Element] -- ^ Elements with given class. +getElementsByClassName window s = + mapM fromJSObject =<< callFunction (ffi "document.getElementsByClassName(%1)" s) + +{----------------------------------------------------------------------------- + Layout +------------------------------------------------------------------------------} +-- | Align given elements in a row. Special case of 'grid'. +row :: [UI Element] -> UI Element +row xs = grid [xs] + +-- | Align given elements in a column. Special case of 'grid'. +column :: [UI Element] -> UI Element +column = grid . map (:[]) + +-- | Align given elements in a rectangular grid. +-- +-- Layout is achieved by using the CSS @display:table@ property. +-- The following element tree will be generated +-- +-- >
+-- >
+-- >
...
+-- >
...
+-- >
+-- >
+-- > ... +-- >
+-- > ... +-- >
+-- +-- You can customatize the actual layout by assigning an @id@ to the element +-- and changing the @.table@, @.table-row@ and @table-column@ +-- classes in a custom CSS file. +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] + wrap "table-row" row + wrap "table" rows + + where + wrap c xs = mkElement "div" # set (attr "class") c #+ map element xs + +{----------------------------------------------------------------------------- + Events +------------------------------------------------------------------------------} +-- | Convenience function to register 'Event's for 'Element's. +-- +-- Example usage. +-- +-- > on click element $ \_ -> ... +on :: (element -> Event a) -> element -> (a -> UI void) -> UI () +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 + window <- askWindow + let flush = liftJSWindow $ \w -> do + mode <- JS.getCallBufferMode w + case mode of + FlushOften -> JS.flushCallBuffer w + _ -> return () + unregister <- liftIO $ register e (void . runUI window . (>> flush) . h) + return (liftIO unregister) + +-- | Execute a 'UI' action whenever a 'Behavior' changes. +-- Use sparingly, it is recommended that you use 'sink' instead. +onChanges :: Behavior a -> (a -> UI void) -> UI () +onChanges b f = do + window <- askWindow + liftIO $ Reactive.onChange b (void . runUI window . f) + +{----------------------------------------------------------------------------- + Attributes +------------------------------------------------------------------------------} +infixl 8 # +infixl 8 #+ +infixl 8 #. + +-- | Reverse function application. +-- Allows convenient notation for setting properties. +-- +-- Example usage. +-- +-- > mkElement "div" +-- > # set style [("color","#CCAABB")] +-- > # set draggable True +-- > # set children otherElements +(#) :: a -> (a -> b) -> b +(#) = flip ($) + +-- | Convenient combinator for setting the CSS class on element creation. +(#.) :: UI Element -> String -> UI Element +(#.) mx s = mx # set (attr "class") s + +-- | Attributes can be 'set' and 'get'. +type Attr x a = ReadWriteAttr x a a + +-- | Attribute that only supports the 'get' operation. +type ReadAttr x o = ReadWriteAttr x () o + +-- | Attribute that only supports the 'set' operation. +type WriteAttr x i = ReadWriteAttr x i () + +-- | Generalized attribute with different types for getting and setting. +data ReadWriteAttr x i o = ReadWriteAttr + { get' :: x -> UI o + , set' :: i -> x -> UI () + } + +instance Functor (ReadWriteAttr x i) where + fmap f = bimapAttr id f + +-- | Map input and output type of an attribute. +bimapAttr :: (i' -> i) -> (o -> o') + -> ReadWriteAttr x i o -> ReadWriteAttr x i' o' +bimapAttr from to attr = attr + { get' = fmap to . get' attr + , set' = \i' -> set' attr (from i') + } + +-- | Set value of an attribute in the 'UI' monad. +-- Best used in conjunction with '#'. +set :: ReadWriteAttr x i o -> i -> UI x -> UI x +set attr i mx = do { x <- mx; set' attr i x; return x; } + +-- | Set the value of an attribute to a 'Behavior', that is a time-varying value. +-- +-- Note: For reasons of efficiency, the attribute is only +-- updated when the value changes. +sink :: ReadWriteAttr x i o -> Behavior i -> UI x -> UI x +sink attr bi mx = do + x <- mx + window <- askWindow + liftIOLater $ do + i <- currentValue bi + runUI window $ set' attr i x + Reactive.onChange bi $ \i -> runUI window $ set' attr i x + return x + +-- | Get attribute value. +get :: ReadWriteAttr x i o -> x -> UI o +get attr = get' attr + +-- | Build an attribute from a getter and a setter. +mkReadWriteAttr + :: (x -> UI o) -- ^ Getter. + -> (i -> x -> UI ()) -- ^ Setter. + -> ReadWriteAttr x i o +mkReadWriteAttr get set = ReadWriteAttr { get' = get, set' = set } + +-- | Build attribute from a getter. +mkReadAttr :: (x -> UI o) -> ReadAttr x o +mkReadAttr get = mkReadWriteAttr get (\_ _ -> return ()) + +-- | Build attribute from a setter. +mkWriteAttr :: (i -> x -> UI ()) -> WriteAttr x i +mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set + +-- | Turn a jQuery property @.prop()@ into an attribute. +fromJQueryProp :: String -> (JSON.Value -> a) -> (a -> JSON.Value) -> Attr Element a +fromJQueryProp name from to = mkReadWriteAttr get set + where + set v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v) + get el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name + +-- | Turn a JavaScript object property @.prop = ...@ into an attribute. +fromObjectProperty :: (FromJS a, ToJS a) => String -> Attr Element a +fromObjectProperty name = mkReadWriteAttr get set + where + set v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v + get el = callFunction $ ffi ("%1." ++ name) el + +{----------------------------------------------------------------------------- + Widget class +------------------------------------------------------------------------------} +-- | Widgets are data types that have a visual representation. +class Widget w where + getElement :: w -> Element + +instance Widget Element where + getElement = id + +-- | Convenience synonym for 'return' to make elements work well with 'set'. +-- Also works on 'Widget's. +-- +-- Example usage. +-- +-- > e <- mkElement "button" +-- > element e # set text "Ok" +element :: MonadIO m => Widget w => w -> m Element +element = return . getElement + +-- | Convenience synonym for 'return' to make widgets work well with 'set'. +widget :: Widget w => w -> UI w +widget = return diff --git a/src/Graphics/UI/Threepenny/DragNDrop.hs b/src/Graphics/UI/Threepenny/DragNDrop.hs --- a/src/Graphics/UI/Threepenny/DragNDrop.hs +++ b/src/Graphics/UI/Threepenny/DragNDrop.hs @@ -1,110 +1,110 @@ -module Graphics.UI.Threepenny.DragNDrop ( - -- * Synopsis - -- | API for handling drag and drop operations. - -- - -- See the documentation below for details on the drag and drop model. - -- - -- WARNING: Events in this module may not behave as expected. - -- The model is currently implemented in terms of HTML 5 drag and drop, - -- but unfortunately, - -- the HTML 5 specification for drag and drop is horrible and - -- browser implementations are buggy. - - -- * Documentation - draggable, droppable, dragData, - DragData, - drag, dragStart, dragEnd, drop, dragEnter, dragLeave, dragOver, - ) where - -import Prelude hiding (drop) -import Control.Monad -import Graphics.UI.Threepenny.Core - -{----------------------------------------------------------------------------- - Attributes -------------------------------------------------------------------------------} --- | Enable or disable whether the element can be dragged by the user. --- --- An element with draggable set to 'True' will receive --- 'drag', 'dragStart' and 'dragEnd' events. -draggable :: WriteAttr Element Bool -draggable = mkWriteAttr set - where - set v = set' (attr "draggable") $ if v then "true" else "false" - --- | Set the data that is transferred when dragging this element. -dragData :: WriteAttr Element DragData -dragData = mkWriteAttr set - where - set v = set' (attr "ondragstart") $ - "event.dataTransfer.setData('dragData', '" ++ v ++ "')" - --- | Enable or disable whether the element accepts drops. --- --- An element with 'droppable' set to 'True' will receive --- 'drop', 'dragOver', 'dragEnter' and 'dragLeave' events. --- --- Child elements of a 'droppable' element may also be 'droppable'. --- When dragging something over an element, the closest ancestor element --- that is 'droppable' will be the target and receive corresponding --- events. -droppable :: WriteAttr Element Bool -droppable = mkWriteAttr enable - where - enable v = void . if v then allowDrop else blockDrop - allowDrop el = - element el - # set (attr "ondragover") "event.preventDefault()" - # set (attr "ondrop" ) "event.preventDefault()" - blockDrop el = - element el - # set (attr "ondragover") "" - # set (attr "ondrop" ) "" - -{----------------------------------------------------------------------------- - Events -------------------------------------------------------------------------------} --- | Data carried by a dragged element. --- --- FIXME: Empty data is currently encoded by the empty String. --- Change this to 'Maybe String' instead. -type DragData = String - -withDragData = fmap (extract . unsafeFromJSON) - where - extract [s] = s - extract _ = "" - --- | Occurs periodically while the element is being dragged around. -drag :: Element -> Event DragData -drag = withDragData . domEvent "drag" - --- | Dragging the element starts. -dragStart :: Element -> Event DragData -dragStart = withDragData . domEvent "dragstart" - --- | Dragging the element ends. --- --- WARNING: This event can occur both before and after a corresponding 'drop' event. -dragEnd :: Element -> Event DragData -dragEnd = withDragData . domEvent "dragend" - --- | The element is now the current target element for a 'drop'. --- --- WARNING: This element is buggy when moving the mouse over child elements. -dragEnter :: Element -> Event DragData -dragEnter = withDragData . domEvent "dragenter" - --- | Occurs periodically while the element is the current target element. -dragOver :: Element -> Event DragData -dragOver = withDragData . domEvent "dragover" - --- | The element is no longer the current target element for a 'drop'. --- --- WARNING: This event is also fired when the mouse is moved over a child element. -dragLeave :: Element -> Event DragData -dragLeave = withDragData . domEvent "dragleave" - --- | The drag and drop operation is being completed on this element. -drop :: Element -> Event DragData -drop = withDragData . domEvent "drop" +module Graphics.UI.Threepenny.DragNDrop ( + -- * Synopsis + -- | API for handling drag and drop operations. + -- + -- See the documentation below for details on the drag and drop model. + -- + -- WARNING: Events in this module may not behave as expected. + -- The model is currently implemented in terms of HTML 5 drag and drop, + -- but unfortunately, + -- the HTML 5 specification for drag and drop is horrible and + -- browser implementations are buggy. + + -- * Documentation + draggable, droppable, dragData, + DragData, + drag, dragStart, dragEnd, drop, dragEnter, dragLeave, dragOver, + ) where + +import Prelude hiding (drop) +import Control.Monad +import Graphics.UI.Threepenny.Core + +{----------------------------------------------------------------------------- + Attributes +------------------------------------------------------------------------------} +-- | Enable or disable whether the element can be dragged by the user. +-- +-- An element with draggable set to 'True' will receive +-- 'drag', 'dragStart' and 'dragEnd' events. +draggable :: WriteAttr Element Bool +draggable = mkWriteAttr set + where + set v = set' (attr "draggable") $ if v then "true" else "false" + +-- | Set the data that is transferred when dragging this element. +dragData :: WriteAttr Element DragData +dragData = mkWriteAttr set + where + set v = set' (attr "ondragstart") $ + "event.dataTransfer.setData('dragData', '" ++ v ++ "')" + +-- | Enable or disable whether the element accepts drops. +-- +-- An element with 'droppable' set to 'True' will receive +-- 'drop', 'dragOver', 'dragEnter' and 'dragLeave' events. +-- +-- Child elements of a 'droppable' element may also be 'droppable'. +-- When dragging something over an element, the closest ancestor element +-- that is 'droppable' will be the target and receive corresponding +-- events. +droppable :: WriteAttr Element Bool +droppable = mkWriteAttr enable + where + enable v = void . if v then allowDrop else blockDrop + allowDrop el = + element el + # set (attr "ondragover") "event.preventDefault()" + # set (attr "ondrop" ) "event.preventDefault()" + blockDrop el = + element el + # set (attr "ondragover") "" + # set (attr "ondrop" ) "" + +{----------------------------------------------------------------------------- + Events +------------------------------------------------------------------------------} +-- | Data carried by a dragged element. +-- +-- FIXME: Empty data is currently encoded by the empty String. +-- Change this to 'Maybe String' instead. +type DragData = String + +withDragData = fmap (extract . unsafeFromJSON) + where + extract [s] = s + extract _ = "" + +-- | Occurs periodically while the element is being dragged around. +drag :: Element -> Event DragData +drag = withDragData . domEvent "drag" + +-- | Dragging the element starts. +dragStart :: Element -> Event DragData +dragStart = withDragData . domEvent "dragstart" + +-- | Dragging the element ends. +-- +-- WARNING: This event can occur both before and after a corresponding 'drop' event. +dragEnd :: Element -> Event DragData +dragEnd = withDragData . domEvent "dragend" + +-- | The element is now the current target element for a 'drop'. +-- +-- WARNING: This element is buggy when moving the mouse over child elements. +dragEnter :: Element -> Event DragData +dragEnter = withDragData . domEvent "dragenter" + +-- | Occurs periodically while the element is the current target element. +dragOver :: Element -> Event DragData +dragOver = withDragData . domEvent "dragover" + +-- | The element is no longer the current target element for a 'drop'. +-- +-- WARNING: This event is also fired when the mouse is moved over a child element. +dragLeave :: Element -> Event DragData +dragLeave = withDragData . domEvent "dragleave" + +-- | The drag and drop operation is being completed on this element. +drop :: Element -> Event DragData +drop = withDragData . domEvent "drop" diff --git a/src/Graphics/UI/Threepenny/Elements.hs b/src/Graphics/UI/Threepenny/Elements.hs --- a/src/Graphics/UI/Threepenny/Elements.hs +++ b/src/Graphics/UI/Threepenny/Elements.hs @@ -1,137 +1,137 @@ --- | Predefined DOM elements, for convenience. -module Graphics.UI.Threepenny.Elements ( - -- * Combinations and utilities - addStyleSheet, - -- text, - new, - - -- * Primitive HTML elements - address, a, anchor, applet, area, audio, - basefont, big, blockquote, body, bold, br, button, - canvas, caption, center, cite, code, - ddef, define, div, dlist, - dterm, emphasize, fieldset, font, form, frame, frameset, - h1, h2, h3, h4, h5, h6, header, hr, - img, image, input, italics, - keyboard, label, legend, li, link, map, meta, noframes, olist, option, - p, paragraph, param, pre, - sample, select, small, source, span, strong, sub, sup, - table, td, textarea, th, thebase, - thehtml, title_, tr, tt, ul, - underline, variable, video, - ) where - -import Control.Monad -import Control.Monad.Trans.Reader -import Graphics.UI.Threepenny.Core -import Prelude hiding (div, map, span) - -{----------------------------------------------------------------------------- - Combinations -------------------------------------------------------------------------------} --- | Add a stylesheet to the head. --- --- The second argument refers to the filename of the stylesheet, --- but not its complete filepath. --- Threepenny will prefix the 'css' subdirectory of the 'tpStatic' configuration field --- to construct the complete filepath. -addStyleSheet - :: Window - -> FilePath - -> UI () -addStyleSheet w filename = void $ do - el <- mkElement "link" - # set (attr "rel" ) "stylesheet" - # set (attr "type") "text/css" - # set (attr "href") ("/static/css/" ++ filename) - getHead w #+ [element el] - --- | Make a new @div@ element, synonym for 'div'. -new :: UI Element -new = div - -{----------------------------------------------------------------------------- - Primitives - - Taken from the HTML library (BSD3 license) - http://hackage.haskell.org/package/html -------------------------------------------------------------------------------} -tag = mkElement -itag = mkElement - -address = tag "address" -a = anchor -anchor = tag "a" -applet = tag "applet" -area = itag "area" -audio = tag "audio" -basefont = itag "basefont" -big = tag "big" -blockquote = tag "blockquote" -body = tag "body" -bold = tag "b" -br = itag "br" -button = tag "button" -canvas = tag "canvas" -caption = tag "caption" -center = tag "center" -cite = tag "cite" -code = tag "code" -ddef = tag "dd" -define = tag "dfn" -div = tag "div" -dlist = tag "dl" -dterm = tag "dt" -emphasize = tag "em" -fieldset = tag "fieldset" -font = tag "font" -form = tag "form" -frame = tag "frame" -frameset = tag "frameset" -h1 = tag "h1" -h2 = tag "h2" -h3 = tag "h3" -h4 = tag "h4" -h5 = tag "h5" -h6 = tag "h6" -header = tag "head" -hr = itag "hr" -img = image -image = itag "img" -input = itag "input" -italics = tag "i" -keyboard = tag "kbd" -label = tag "label" -legend = tag "legend" -li = tag "li" -link = tag "link" -map = tag "map" -meta = itag "meta" -noframes = tag "noframes" -olist = tag "ol" -option = tag "option" -p = tag "p" -paragraph = tag "p" -param = itag "param" -pre = tag "pre" -sample = tag "samp" -select = tag "select" -small = tag "small" -source = tag "source" -strong = tag "strong" -sub = tag "sub" -sup = tag "sup" -table = tag "table" -td = tag "td" -textarea = tag "textarea" -th = tag "th" -thebase = itag "base" -thehtml = tag "html" -span = tag "span" -title_ = tag "title" -tr = tag "tr" -tt = tag "tt" -ul = tag "ul" -underline = tag "u" -variable = tag "var" -video = tag "video" +-- | Predefined DOM elements, for convenience. +module Graphics.UI.Threepenny.Elements ( + -- * Combinations and utilities + addStyleSheet, + -- text, + new, + + -- * Primitive HTML elements + address, a, anchor, applet, area, audio, + basefont, big, blockquote, body, bold, br, button, + canvas, caption, center, cite, code, + ddef, define, div, dlist, + dterm, emphasize, fieldset, font, form, frame, frameset, + h1, h2, h3, h4, h5, h6, header, hr, + img, image, input, italics, + keyboard, label, legend, li, link, map, meta, noframes, olist, option, + p, paragraph, param, pre, + sample, select, small, source, span, strong, sub, sup, + table, td, textarea, th, thebase, + thehtml, title_, tr, tt, ul, + underline, variable, video, + ) where + +import Control.Monad +import Control.Monad.Trans.Reader +import Graphics.UI.Threepenny.Core +import Prelude hiding (div, map, span) + +{----------------------------------------------------------------------------- + Combinations +------------------------------------------------------------------------------} +-- | Add a stylesheet to the head. +-- +-- The second argument refers to the filename of the stylesheet, +-- but not its complete filepath. +-- Threepenny will prefix the 'css' subdirectory of the 'tpStatic' configuration field +-- to construct the complete filepath. +addStyleSheet + :: Window + -> FilePath + -> UI () +addStyleSheet w filename = void $ do + el <- mkElement "link" + # set (attr "rel" ) "stylesheet" + # set (attr "type") "text/css" + # set (attr "href") ("/static/css/" ++ filename) + getHead w #+ [element el] + +-- | Make a new @div@ element, synonym for 'div'. +new :: UI Element +new = div + +{----------------------------------------------------------------------------- + Primitives + + Taken from the HTML library (BSD3 license) + http://hackage.haskell.org/package/html +------------------------------------------------------------------------------} +tag = mkElement +itag = mkElement + +address = tag "address" +a = anchor +anchor = tag "a" +applet = tag "applet" +area = itag "area" +audio = tag "audio" +basefont = itag "basefont" +big = tag "big" +blockquote = tag "blockquote" +body = tag "body" +bold = tag "b" +br = itag "br" +button = tag "button" +canvas = tag "canvas" +caption = tag "caption" +center = tag "center" +cite = tag "cite" +code = tag "code" +ddef = tag "dd" +define = tag "dfn" +div = tag "div" +dlist = tag "dl" +dterm = tag "dt" +emphasize = tag "em" +fieldset = tag "fieldset" +font = tag "font" +form = tag "form" +frame = tag "frame" +frameset = tag "frameset" +h1 = tag "h1" +h2 = tag "h2" +h3 = tag "h3" +h4 = tag "h4" +h5 = tag "h5" +h6 = tag "h6" +header = tag "head" +hr = itag "hr" +img = image +image = itag "img" +input = itag "input" +italics = tag "i" +keyboard = tag "kbd" +label = tag "label" +legend = tag "legend" +li = tag "li" +link = tag "link" +map = tag "map" +meta = itag "meta" +noframes = tag "noframes" +olist = tag "ol" +option = tag "option" +p = tag "p" +paragraph = tag "p" +param = itag "param" +pre = tag "pre" +sample = tag "samp" +select = tag "select" +small = tag "small" +source = tag "source" +strong = tag "strong" +sub = tag "sub" +sup = tag "sup" +table = tag "table" +td = tag "td" +textarea = tag "textarea" +th = tag "th" +thebase = itag "base" +thehtml = tag "html" +span = tag "span" +title_ = tag "title" +tr = tag "tr" +tt = tag "tt" +ul = tag "ul" +underline = tag "u" +variable = tag "var" +video = tag "video" diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs --- a/src/Graphics/UI/Threepenny/Events.hs +++ b/src/Graphics/UI/Threepenny/Events.hs @@ -1,99 +1,106 @@ -module Graphics.UI.Threepenny.Events ( - -- * Synopsis - -- | Events on DOM elements. - - -- * Convenience events - valueChange, selectionChange, checkedChange, - - -- * Standard DOM events - click, contextmenu, mousemove, mousedown, mouseup, - hover, leave, - focus, blur, - KeyCode, keyup, keydown, - ) where - -import Graphics.UI.Threepenny.Attributes -import Graphics.UI.Threepenny.Core - -silence = fmap (const ()) - -{----------------------------------------------------------------------------- - Events -------------------------------------------------------------------------------} --- | Event that occurs when the /user/ changes the value of the input element. -valueChange :: Element -> Event String -valueChange el = unsafeMapUI el (const $ get value el) (domEvent "keydown" el) - -unsafeMapUI el f = unsafeMapIO (\a -> getWindow el >>= \w -> runUI w (f a)) - --- | Event that occurs when the /user/ changes the selection of a @@ element. +selectionChange :: Element -> Event (Maybe Int) +selectionChange el = unsafeMapUI el (const $ get selection el) (click el) + +-- | Event that occurs when the /user/ changes the checked status of an input +-- element of type checkbox. +checkedChange :: Element -> Event Bool +checkedChange el = unsafeMapUI el (const $ get checked el) (click el) + +{----------------------------------------------------------------------------- + DOM Events +------------------------------------------------------------------------------} +-- | Mouse click. +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" + +-- | Event that periodically occurs while the mouse is moving over an element. +-- +-- The event value represents the mouse coordinates +-- relative to the upper left corner of the element. +-- +-- Note: The @@ element responds to mouse move events, +-- but only in the area occupied by actual content, +-- not the whole browser window. +mousemove :: Element -> Event (Int,Int) +mousemove = fmap readCoordinates . domEvent "mousemove" + +readCoordinates :: EventData -> (Int,Int) +readCoordinates json = (x,y) + where [x,y] = unsafeFromJSON json + +-- | Mouse down event. +-- 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. +mouseup :: Element -> Event (Int,Int) +mouseup = fmap readCoordinates . domEvent "mouseup" + +-- | Mouse leaving an element. +leave :: Element -> Event () +leave = silence . domEvent "mouseleave" + +-- | Element receives focus. +focus :: Element -> Event () +focus = silence . domEvent "focus" + +-- | Element loses focus. +blur :: Element -> Event () +blur = silence . domEvent "blur" + + +type KeyCode = Int + +-- | Key pressed while element has focus. +-- Returns the keycode (as opposed to the ASCII value) of any key, including +-- SHIFT, CTRL and arrow keys. +keydown :: Element -> Event KeyCode +keydown = fmap unsafeFromJSON . domEvent "keydown" + +-- | Key released while element has focus. +keyup :: Element -> Event KeyCode +keyup = fmap unsafeFromJSON . domEvent "keyup" + +-- | Key pressed while element has focus. +-- Returns the actual character, taking into account SHIFT or CAPS LOCK. +keypress :: Element -> Event Char +keypress = fmap (toEnum . read . head . unsafeFromJSON) . domEvent "keypress" diff --git a/src/Graphics/UI/Threepenny/Internal.hs b/src/Graphics/UI/Threepenny/Internal.hs --- a/src/Graphics/UI/Threepenny/Internal.hs +++ b/src/Graphics/UI/Threepenny/Internal.hs @@ -1,383 +1,383 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Graphics.UI.Threepenny.Internal ( - -- * Synopsis - -- | Internal core: - -- 'UI' monad, integrating FRP and JavaScript FFI. garbage collection - - -- * Documentation - Window, disconnect, - startGUI, loadFile, loadDirectory, - - UI, runUI, MonadUI(..), liftIOLater, askWindow, liftJSWindow, - - FFI, FromJS, ToJS, JSFunction, JSObject, ffi, - runFunction, callFunction, - CallBufferMode(..), setCallBufferMode, flushCallBuffer, - ffiExport, debug, timestamp, - - Element(toJSObject), fromJSObject, getWindow, - mkElementNamespace, mkElement, delete, appendChild, clearChildren, - - EventData, domEvent, unsafeFromJSON, - ) where - -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 -import Data.Dynamic (Typeable) - -import qualified Data.Aeson as JSON -import qualified Foreign.JavaScript as JS -import qualified Foreign.RemotePtr as Foreign - -import qualified Reactive.Threepenny as RB - -import Foreign.JavaScript hiding - (runFunction, callFunction, setCallBufferMode, flushCallBuffer - ,debug, timestamp, Window, loadFile, loadDirectory) - -{----------------------------------------------------------------------------- - Custom Window type -------------------------------------------------------------------------------} --- | The type 'Window' represents a browser window. -data Window = Window - { jsWindow :: JS.Window -- JavaScript window - , eDisconnect :: RB.Event () -- event that happens when client disconnects - , wEvents :: Foreign.Vendor Events - -- events associated to 'Element's - , wChildren :: Foreign.Vendor () - -- children reachable from 'Element's - } - --- | Start server for GUI sessions. -startGUI - :: Config -- ^ Server configuration. - -> (Window -> UI ()) -- ^ Action to run whenever a client browser connects. - -> IO () -startGUI config init = JS.serve config $ \w -> do - -- set up disconnect event - (eDisconnect, handleDisconnect) <- RB.newEvent - JS.onDisconnect w $ handleDisconnect () - - -- make window - wEvents <- Foreign.newVendor - wChildren <- Foreign.newVendor - let window = Window - { jsWindow = w - , eDisconnect = eDisconnect - , wEvents = wEvents - , wChildren = wChildren - } - - -- run initialization - runUI window $ init window - --- | Event that occurs whenever the client has disconnected, --- be it by closing the browser window or by exception. --- --- Note: DOM Elements in a browser window that has been closed --- can no longer be manipulated. -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 -> RB.Event JSON.Value - --- Reachability information for children of an 'Element'. --- The children of an element are always reachable from this RemotePtr. -type Children = Foreign.RemotePtr () - -data Element = Element - { toJSObject :: JS.JSObject -- ^ Access to the primitive 'JS.JSObject' for roll-your-own foreign calls. - , elEvents :: Events -- ^ FRP event mapping - , elChildren :: Children -- ^ The children of this element - , elWindow :: Window -- ^ Window in which the element was created - } deriving (Typeable) - -instance ToJS Element where - render = render . toJSObject - -getWindow :: Element -> IO Window -getWindow = return . elWindow - --- | Lookup or create reachability information for the children of --- an element that is represented by a JavaScript object. -getChildren :: JS.JSObject -> Window -> IO Children -getChildren el window@Window{ wChildren = wChildren } = - Foreign.withRemotePtr el $ \coupon _ -> do - mptr <- Foreign.lookup coupon wChildren - case mptr of - Nothing -> do - -- Create new pointer for reachability information. - ptr <- Foreign.newRemotePtr coupon () wChildren - Foreign.addReachable el ptr - return ptr - Just p -> - -- Return existing information - return p - --- | Convert JavaScript object into an Element by attaching relevant information. --- The JavaScript object may still be subject to garbage collection. -fromJSObject0 :: JS.JSObject -> Window -> IO Element -fromJSObject0 el window = do - events <- getEvents el window - children <- getChildren el window - return $ Element el events children window - --- | Convert JavaScript object into an element. --- --- FIXME: For the purpose of garbage collection, this element --- will always be reachable from the root. -fromJSObject :: JS.JSObject -> UI Element -fromJSObject el = do - window <- askWindow - liftIO $ do - Foreign.addReachable (JS.root $ jsWindow window) el - fromJSObject0 el window - --- | Add lazy FRP events to a JavaScript object. -addEvents :: JS.JSObject -> Window -> IO Events -addEvents el Window{ jsWindow = w, wEvents = wEvents } = do - -- Lazily create FRP events whenever they are needed. - let initializeEvent (name,_,handler) = do - handlerPtr <- JS.exportHandler w handler - -- make handler reachable from element - Foreign.addReachable el handlerPtr - JS.runFunction w $ - ffi "Haskell.on(%1,%2,%3)" el name handlerPtr - - events <- RB.newEventsNamed initializeEvent - - -- Create new pointer and add reachability. - Foreign.withRemotePtr el $ \coupon _ -> do - ptr <- Foreign.newRemotePtr coupon events wEvents - Foreign.addReachable el ptr - - return events - --- | Lookup or create lazy events for a JavaScript object. -getEvents :: JS.JSObject -> Window -> IO Events -getEvents el window@Window{ wEvents = wEvents } = do - Foreign.withRemotePtr el $ \coupon _ -> do - mptr <- Foreign.lookup coupon wEvents - case mptr of - Nothing -> addEvents el window - Just p -> Foreign.withRemotePtr p $ \_ -> return - --- | Events may carry data. At the moment, they may return --- a single JSON value, as defined in the "Data.Aeson" module. -type EventData = JSON.Value - --- | Convert event data to a Haskell value. --- Throws an exception when the data cannot be converted. -unsafeFromJSON :: JSON.FromJSON a => EventData -> a -unsafeFromJSON x = let JSON.Success y = JSON.fromJSON x in y - --- | Obtain DOM event for a given element. -domEvent - :: String - -- ^ Event name. A full list can be found at - -- . - -- Note that the @on@-prefix is not included, - -- the name is @click@ and so on. - -> Element -- ^ Element where the event is to occur. - -> RB.Event EventData -domEvent name el = elEvents el name - --- | Make a new DOM element with a given tag name. -mkElement :: String -> UI Element -mkElement = mkElementNamespace Nothing - --- | Make a new DOM element with a namespace and a given tag name. --- --- A namespace 'Nothing' corresponds to the default HTML namespace. -mkElementNamespace :: Maybe String -> String -> UI Element -mkElementNamespace namespace tag = do - window <- askWindow - let w = jsWindow window - liftIO $ do - el <- JS.unsafeCreateJSObject w $ case namespace of - Nothing -> ffi "document.createElement(%1)" tag - Just ns -> ffi "document.createElementNS(%1,%2)" ns tag - 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 - Foreign.destroy $ toJSObject el - --- | Remove all child elements. -clearChildren :: Element -> UI () -clearChildren element = liftJSWindow $ \w -> do - let el = toJSObject element - Foreign.withRemotePtr el $ \_ _ -> do - -- Previous children are no longer reachable from this element - JS.runFunction w $ ffi "$(%1).contents().detach()" el - Foreign.clearReachable (elChildren element) - --- | Append a child element. -appendChild :: Element -> Element -> UI () -appendChild parent child = liftJSWindow $ \w -> do - -- FIXME: We have to stop the child being reachable from its - -- /previous/ parent. - Foreign.addReachable (elChildren parent) (toJSObject child) - JS.runFunction w $ ffi "$(%1).append($(%2))" (toJSObject parent) (toJSObject child) - - -{----------------------------------------------------------------------------- - UI monad -------------------------------------------------------------------------------} -{- | - -User interface elements are created and manipulated in the 'UI' monad. - -This monad is essentially just a thin wrapper around the familiar 'IO' monad. -Use the 'liftIO' function to access 'IO' operations like reading -and writing from files. - -There are several subtle reasons why Threepenny -uses a custom 'UI' monad instead of the standard 'IO' monad: - -* More convenience when calling JavaScript. -The monad keeps track of a browser 'Window' context -in which JavaScript function calls are executed. - -* Recursion for functional reactive programming. - --} -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 - --- | Access to the primitive 'JS.Window' object, --- for roll-your-own JS foreign calls. -liftJSWindow :: (JS.Window -> IO a) -> UI a -liftJSWindow f = askWindow >>= liftIO . f . jsWindow - -instance Functor UI where - fmap f = UI . fmap f . unUI - -instance Applicative UI where - pure = return - (<*>) = ap - -instance Monad UI where - return = UI . return - m >>= k = UI $ unUI m >>= unUI . k - -instance MonadIO UI where - liftIO = UI . liftIO - -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 -runUI window m = do - (a, _, actions) <- Monad.runRWST (unUI m) window () - sequence_ actions - return a - --- | Retrieve current 'Window' context in the 'UI' monad. -askWindow :: UI Window -askWindow = UI Monad.ask - --- | Schedule an 'IO' action to be run later. -liftIOLater :: IO () -> UI () -liftIOLater x = UI $ Monad.tell [x] - -{----------------------------------------------------------------------------- - FFI -------------------------------------------------------------------------------} --- | Run a JavaScript function, but do not wait for a result. --- --- 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 - --- | Call a JavaScript function and wait for the result. --- --- The client window uses JavaScript's @eval()@ function to run the code. -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. --- --- 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 - Foreign.addReachable (JS.root w) handlerPtr - return handlerPtr - --- | Print a message on the client console if the client has debugging enabled. -debug :: String -> UI () -debug s = liftJSWindow $ \w -> JS.debug w s - --- | Print a timestamp and the difference to the previous timestamp --- on the client console if the client has debugging enabled. -timestamp :: UI () -timestamp = liftJSWindow JS.timestamp - +{-# LANGUAGE DeriveDataTypeable #-} +module Graphics.UI.Threepenny.Internal ( + -- * Synopsis + -- | Internal core: + -- 'UI' monad, integrating FRP and JavaScript FFI. garbage collection + + -- * Documentation + Window, disconnect, + startGUI, loadFile, loadDirectory, + + UI, runUI, MonadUI(..), liftIOLater, askWindow, liftJSWindow, + + FFI, FromJS, ToJS, JSFunction, JSObject, ffi, + runFunction, callFunction, + CallBufferMode(..), setCallBufferMode, flushCallBuffer, + ffiExport, debug, timestamp, + + Element(toJSObject), fromJSObject, getWindow, + mkElementNamespace, mkElement, delete, appendChild, clearChildren, + + EventData, domEvent, unsafeFromJSON, + ) where + +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 +import Data.Dynamic (Typeable) + +import qualified Data.Aeson as JSON +import qualified Foreign.JavaScript as JS +import qualified Foreign.RemotePtr as Foreign + +import qualified Reactive.Threepenny as RB + +import Foreign.JavaScript hiding + (runFunction, callFunction, setCallBufferMode, flushCallBuffer + ,debug, timestamp, Window, loadFile, loadDirectory) + +{----------------------------------------------------------------------------- + Custom Window type +------------------------------------------------------------------------------} +-- | The type 'Window' represents a browser window. +data Window = Window + { jsWindow :: JS.Window -- JavaScript window + , eDisconnect :: RB.Event () -- event that happens when client disconnects + , wEvents :: Foreign.Vendor Events + -- events associated to 'Element's + , wChildren :: Foreign.Vendor () + -- children reachable from 'Element's + } + +-- | Start server for GUI sessions. +startGUI + :: Config -- ^ Server configuration. + -> (Window -> UI ()) -- ^ Action to run whenever a client browser connects. + -> IO () +startGUI config init = JS.serve config $ \w -> do + -- set up disconnect event + (eDisconnect, handleDisconnect) <- RB.newEvent + JS.onDisconnect w $ handleDisconnect () + + -- make window + wEvents <- Foreign.newVendor + wChildren <- Foreign.newVendor + let window = Window + { jsWindow = w + , eDisconnect = eDisconnect + , wEvents = wEvents + , wChildren = wChildren + } + + -- run initialization + runUI window $ init window + +-- | Event that occurs whenever the client has disconnected, +-- be it by closing the browser window or by exception. +-- +-- Note: DOM Elements in a browser window that has been closed +-- can no longer be manipulated. +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 -> RB.Event JSON.Value + +-- Reachability information for children of an 'Element'. +-- The children of an element are always reachable from this RemotePtr. +type Children = Foreign.RemotePtr () + +data Element = Element + { toJSObject :: JS.JSObject -- ^ Access to the primitive 'JS.JSObject' for roll-your-own foreign calls. + , elEvents :: Events -- ^ FRP event mapping + , elChildren :: Children -- ^ The children of this element + , elWindow :: Window -- ^ Window in which the element was created + } deriving (Typeable) + +instance ToJS Element where + render = render . toJSObject + +getWindow :: Element -> IO Window +getWindow = return . elWindow + +-- | Lookup or create reachability information for the children of +-- an element that is represented by a JavaScript object. +getChildren :: JS.JSObject -> Window -> IO Children +getChildren el window@Window{ wChildren = wChildren } = + Foreign.withRemotePtr el $ \coupon _ -> do + mptr <- Foreign.lookup coupon wChildren + case mptr of + Nothing -> do + -- Create new pointer for reachability information. + ptr <- Foreign.newRemotePtr coupon () wChildren + Foreign.addReachable el ptr + return ptr + Just p -> + -- Return existing information + return p + +-- | Convert JavaScript object into an Element by attaching relevant information. +-- The JavaScript object may still be subject to garbage collection. +fromJSObject0 :: JS.JSObject -> Window -> IO Element +fromJSObject0 el window = do + events <- getEvents el window + children <- getChildren el window + return $ Element el events children window + +-- | Convert JavaScript object into an element. +-- +-- FIXME: For the purpose of garbage collection, this element +-- will always be reachable from the root. +fromJSObject :: JS.JSObject -> UI Element +fromJSObject el = do + window <- askWindow + liftIO $ do + Foreign.addReachable (JS.root $ jsWindow window) el + fromJSObject0 el window + +-- | Add lazy FRP events to a JavaScript object. +addEvents :: JS.JSObject -> Window -> IO Events +addEvents el Window{ jsWindow = w, wEvents = wEvents } = do + -- Lazily create FRP events whenever they are needed. + let initializeEvent (name,_,handler) = do + handlerPtr <- JS.exportHandler w handler + -- make handler reachable from element + Foreign.addReachable el handlerPtr + JS.runFunction w $ + ffi "Haskell.on(%1,%2,%3)" el name handlerPtr + + events <- RB.newEventsNamed initializeEvent + + -- Create new pointer and add reachability. + Foreign.withRemotePtr el $ \coupon _ -> do + ptr <- Foreign.newRemotePtr coupon events wEvents + Foreign.addReachable el ptr + + return events + +-- | Lookup or create lazy events for a JavaScript object. +getEvents :: JS.JSObject -> Window -> IO Events +getEvents el window@Window{ wEvents = wEvents } = do + Foreign.withRemotePtr el $ \coupon _ -> do + mptr <- Foreign.lookup coupon wEvents + case mptr of + Nothing -> addEvents el window + Just p -> Foreign.withRemotePtr p $ \_ -> return + +-- | Events may carry data. At the moment, they may return +-- a single JSON value, as defined in the "Data.Aeson" module. +type EventData = JSON.Value + +-- | Convert event data to a Haskell value. +-- Throws an exception when the data cannot be converted. +unsafeFromJSON :: JSON.FromJSON a => EventData -> a +unsafeFromJSON x = let JSON.Success y = JSON.fromJSON x in y + +-- | Obtain DOM event for a given element. +domEvent + :: String + -- ^ Event name. A full list can be found at + -- . + -- Note that the @on@-prefix is not included, + -- the name is @click@ and so on. + -> Element -- ^ Element where the event is to occur. + -> RB.Event EventData +domEvent name el = elEvents el name + +-- | Make a new DOM element with a given tag name. +mkElement :: String -> UI Element +mkElement = mkElementNamespace Nothing + +-- | Make a new DOM element with a namespace and a given tag name. +-- +-- A namespace 'Nothing' corresponds to the default HTML namespace. +mkElementNamespace :: Maybe String -> String -> UI Element +mkElementNamespace namespace tag = do + window <- askWindow + let w = jsWindow window + liftIO $ do + el <- JS.unsafeCreateJSObject w $ case namespace of + Nothing -> ffi "document.createElement(%1)" tag + Just ns -> ffi "document.createElementNS(%1,%2)" ns tag + 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 + Foreign.destroy $ toJSObject el + +-- | Remove all child elements. +clearChildren :: Element -> UI () +clearChildren element = liftJSWindow $ \w -> do + let el = toJSObject element + Foreign.withRemotePtr el $ \_ _ -> do + -- Previous children are no longer reachable from this element + JS.runFunction w $ ffi "$(%1).contents().detach()" el + Foreign.clearReachable (elChildren element) + +-- | Append a child element. +appendChild :: Element -> Element -> UI () +appendChild parent child = liftJSWindow $ \w -> do + -- FIXME: We have to stop the child being reachable from its + -- /previous/ parent. + Foreign.addReachable (elChildren parent) (toJSObject child) + JS.runFunction w $ ffi "$(%1).append($(%2))" (toJSObject parent) (toJSObject child) + + +{----------------------------------------------------------------------------- + UI monad +------------------------------------------------------------------------------} +{- | + +User interface elements are created and manipulated in the 'UI' monad. + +This monad is essentially just a thin wrapper around the familiar 'IO' monad. +Use the 'liftIO' function to access 'IO' operations like reading +and writing from files. + +There are several subtle reasons why Threepenny +uses a custom 'UI' monad instead of the standard 'IO' monad: + +* More convenience when calling JavaScript. +The monad keeps track of a browser 'Window' context +in which JavaScript function calls are executed. + +* Recursion for functional reactive programming. + +-} +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 + +-- | Access to the primitive 'JS.Window' object, +-- for roll-your-own JS foreign calls. +liftJSWindow :: (JS.Window -> IO a) -> UI a +liftJSWindow f = askWindow >>= liftIO . f . jsWindow + +instance Functor UI where + fmap f = UI . fmap f . unUI + +instance Applicative UI where + pure = return + (<*>) = ap + +instance Monad UI where + return = UI . return + m >>= k = UI $ unUI m >>= unUI . k + +instance MonadIO UI where + liftIO = UI . liftIO + +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 +runUI window m = do + (a, _, actions) <- Monad.runRWST (unUI m) window () + sequence_ actions + return a + +-- | Retrieve current 'Window' context in the 'UI' monad. +askWindow :: UI Window +askWindow = UI Monad.ask + +-- | Schedule an 'IO' action to be run later. +liftIOLater :: IO () -> UI () +liftIOLater x = UI $ Monad.tell [x] + +{----------------------------------------------------------------------------- + FFI +------------------------------------------------------------------------------} +-- | Run a JavaScript function, but do not wait for a result. +-- +-- 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 + +-- | Call a JavaScript function and wait for the result. +-- +-- The client window uses JavaScript's @eval()@ function to run the code. +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. +-- +-- 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 + Foreign.addReachable (JS.root w) handlerPtr + return handlerPtr + +-- | Print a message on the client console if the client has debugging enabled. +debug :: String -> UI () +debug s = liftJSWindow $ \w -> JS.debug w s + +-- | Print a timestamp and the difference to the previous timestamp +-- on the client console if the client has debugging enabled. +timestamp :: UI () +timestamp = liftJSWindow JS.timestamp + diff --git a/src/Graphics/UI/Threepenny/JQuery.hs b/src/Graphics/UI/Threepenny/JQuery.hs --- a/src/Graphics/UI/Threepenny/JQuery.hs +++ b/src/Graphics/UI/Threepenny/JQuery.hs @@ -1,44 +1,44 @@ -module Graphics.UI.Threepenny.JQuery where - -import Control.Arrow -import Data.String -import Data.Char -import Data.Default -import Data.Maybe - -import Graphics.UI.Threepenny.Core - -{----------------------------------------------------------------------------- - jQuery utilities -------------------------------------------------------------------------------} -data Easing = Swing | Linear - deriving (Eq,Enum,Show) - -instance Default Easing where def = Linear - --- | Fade in an element. -fadeIn :: Element -> Int -> Easing -> IO () -> UI () -fadeIn el duration easing complete = do - callback <- ffiExport complete - runFunction $ ffi "$(%1).animate({opacity: 1}, %2 * 1, %3, %4)" - el duration (map toLower (show easing)) callback - --- | Fade out an element. -fadeOut :: Element -> Int -> Easing -> IO () -> UI () -fadeOut el duration easing complete = do - callback <- ffiExport complete - runFunction $ ffi "$(%1).animate({opacity: 0}, %2 * 1, %3, %4)" - el duration (map toLower (show easing)) callback - --- | The 'sendValue' event happens whenever the return key is pressed --- while the element has focus. Its data is the event value. -sendValue :: Element -> Event String -sendValue = fmap unsafeFromJSON . domEvent "sendvalue" - --- | Focus an element. -setFocus :: Element -> UI () -setFocus = runFunction . ffi "$(%1).focus()" - --- | Scroll to the bottom of an element. -scrollToBottom :: Element -> UI () -scrollToBottom = runFunction . ffi "jquery_scrollToBottom(%1)" +module Graphics.UI.Threepenny.JQuery where + +import Control.Arrow +import Data.String +import Data.Char +import Data.Default +import Data.Maybe + +import Graphics.UI.Threepenny.Core + +{----------------------------------------------------------------------------- + jQuery utilities +------------------------------------------------------------------------------} +data Easing = Swing | Linear + deriving (Eq,Enum,Show) + +instance Default Easing where def = Linear + +-- | Fade in an element. +fadeIn :: Element -> Int -> Easing -> IO () -> UI () +fadeIn el duration easing complete = do + callback <- ffiExport complete + runFunction $ ffi "$(%1).animate({opacity: 1}, %2 * 1, %3, %4)" + el duration (map toLower (show easing)) callback + +-- | Fade out an element. +fadeOut :: Element -> Int -> Easing -> IO () -> UI () +fadeOut el duration easing complete = do + callback <- ffiExport complete + runFunction $ ffi "$(%1).animate({opacity: 0}, %2 * 1, %3, %4)" + el duration (map toLower (show easing)) callback + +-- | The 'sendValue' event happens whenever the return key is pressed +-- while the element has focus. Its data is the event value. +sendValue :: Element -> Event String +sendValue = fmap unsafeFromJSON . domEvent "sendvalue" + +-- | Focus an element. +setFocus :: Element -> UI () +setFocus = runFunction . ffi "$(%1).focus()" + +-- | Scroll to the bottom of an element. +scrollToBottom :: Element -> UI () +scrollToBottom = runFunction . ffi "jquery_scrollToBottom(%1)" diff --git a/src/Graphics/UI/Threepenny/SVG.hs b/src/Graphics/UI/Threepenny/SVG.hs --- a/src/Graphics/UI/Threepenny/SVG.hs +++ b/src/Graphics/UI/Threepenny/SVG.hs @@ -1,18 +1,18 @@ -module Graphics.UI.Threepenny.SVG ( - -- * Synopsis - -- | SVG elements and attributes. - -- - -- It is recommended that you import this module qualified, i.e. - -- - -- > import qualified Graphics.UI.Threepenny.SVG as SVG - -- - -- Note that some SVG attributes and elements have the same name. - -- In this case, only the most common of either has been imported. - -- If you need the other version, you have to import the individual modules. - - module Graphics.UI.Threepenny.SVG.Attributes, - module Graphics.UI.Threepenny.SVG.Elements - ) where - -import Graphics.UI.Threepenny.SVG.Attributes hiding (path, title, glyphRef) -import Graphics.UI.Threepenny.SVG.Elements hiding (cursor, filter, mask, style) +module Graphics.UI.Threepenny.SVG ( + -- * Synopsis + -- | SVG elements and attributes. + -- + -- It is recommended that you import this module qualified, i.e. + -- + -- > import qualified Graphics.UI.Threepenny.SVG as SVG + -- + -- Note that some SVG attributes and elements have the same name. + -- In this case, only the most common of either has been imported. + -- If you need the other version, you have to import the individual modules. + + module Graphics.UI.Threepenny.SVG.Attributes, + module Graphics.UI.Threepenny.SVG.Elements + ) where + +import Graphics.UI.Threepenny.SVG.Attributes hiding (path, title, glyphRef) +import Graphics.UI.Threepenny.SVG.Elements hiding (cursor, filter, mask, style) diff --git a/src/Graphics/UI/Threepenny/SVG/Attributes.hs b/src/Graphics/UI/Threepenny/SVG/Attributes.hs --- a/src/Graphics/UI/Threepenny/SVG/Attributes.hs +++ b/src/Graphics/UI/Threepenny/SVG/Attributes.hs @@ -1,360 +1,360 @@ -module Graphics.UI.Threepenny.SVG.Attributes ( - -- * Synopsis - -- | SVG attributes as defined by W3C, Scalable Vector Graphics (SVG) 1.1 - -- (Second Edition) Appendix M . - -- - -- Whenever possible, the Haskell identifier for an attribute is the - -- same as the attribute name. However, sometimes changes are necessary: - -- - -- 1. Hyphens @-@ are replaced by underscores @_@, e.g. 'stroke_width'. - -- - -- 2. An underscore is used whenever the attribute name conflicts with - -- a reserved word in Haskell, e.g. 'class_'. - - -- * Regular attributes - accent_height, accumulate, additive, alphabetic, amplitude, - arabic_form, ascent, attributeName, attributeType, azimuth, - baseFrequency, baseProfile, bbox, begin, bias, by, - calcMode, cap_height, class_, clipPathUnits, contentScriptType, - contentStyleType, cx, cy, - d, descent, diffuseConstant, divisor, dur, dx, dy, - edgeMode, elevation, end, exponent, externalResourcesRequired, - filterRes, filterUnits, format, from, fx, fy, - g1, g2, glyph_name, glyphRef, gradientTransform, gradientUnits, - hanging, height, horiz_adv_x, horiz_origin_x, horiz_origin_y, - id, ideographic, in_, in2, intercept, - k, k1, k2, k3, k4, kernelMatrix, kernelUnitLength, - keyPoints, keySplines, keyTimes, - lang, lengthAdjust, limitingConeAngle, local, - markerHeight, markerUnits, markerWidth, maskContentUnits, maskUnits, - mathematical, max, media, method, min, mode, - name, numOctaves, - offset, - onabort, onactivate, onbegin, onclick, onend, onerror, onfocusin, onfocusout, - onload, onmousedown, onmousemove, onmouseout, onmouseover, onmouseup, - onrepeat, onresize, onscroll, onunload, onzoom, - operator, order, orient, orientation, origin, - overline_position, overline_thickness, - panose_1, path, pathLength, patternContentUnits, - patternTransform, patternUnits, points, pointsAtX, pointsAtY, pointsAtZ, - preserveAlpha, preserveAspectRatio, primitiveUnits, - r, radius, refx, refy, rendering_intent, repeatCount, repeatDur, - requiredExtensions, requiredFeatures, restart, result, rotate, rx, ry, - scale, seed, slope, spacing, specularConstant, specularExponent, spreadMethod, - startOffset, stdDeviation, stemh, stemv, stitchTiles, - strikethrough_position, strikethrough_thickness, - string, style, surfaceScale, systemLanguage, - tableValues, target, targetX, targetY, textLength, title, to, transform, type_, - u1, u2, underline_position, underline_thickness, unicode, unicode_range, units_per_em, - v_alphabetic, v_hanging, v_ideographic, v_mathematical, values, version, - vert_adv_y, vert_origin_x, vert_origin_y, viewBox, viewTarget, - width, widths, - x, x_height, x1, x2, xChannelSelector, - xlink_actuate, xlink_arcrole, xlink_href, xlink_role, xlink_show, xlink_title, xlink_type, - xml_base, xml_lang, xml_space, - y, y1, y2, yChannelSelector, - z, zoomAndPan, - - -- * Presentation attributes - alignment_baseline, baseline_shift, - clip_path, clip_rule, clip, color_interpolation_filters, color_interpolation, - color_profile, color_rendering, color, cursor, - direction, display, dominant_baseline, - enable_background, - fill_opacity, fill_rule, fill, filter, flood_color,flood_opacity, - font_family, font_size_adjust, font_size, font_stretch, font_style, font_variant, - font_weight, - glyph_orientation_horizontal, glyph_orientation_vertical, - image_rendering, kerning, - letter_spacing, lighting_color, - marker_end, marker_mid, marker_start, mask, - opacity, overflow, pointer_events, - shape_rendering, stop_color, stop_opacity, - stroke_dasharray, stroke_dashoffset, stroke_linecap, stroke_linejoin, - stroke_miterlimit, stroke_opacity, stroke_width, stroke, - text_anchor, text_decoration, text_rendering, - unicode_bidi, visibility, word_spacing, writing_mode - ) where - - -import Graphics.UI.Threepenny.Core (Element, WriteAttr, attr, - mkWriteAttr, set') -import Prelude hiding (exponent, filter, id, max, - min) - -strAttr :: String -> WriteAttr Element String -strAttr n = mkWriteAttr (set' (attr n)) - -intAttr :: String -> WriteAttr Element Int -intAttr n = mkWriteAttr (set' (attr n) . show) - -fltAttr :: String -> WriteAttr Element Float -fltAttr n = mkWriteAttr (set' (attr n) . show) - -accent_height = fltAttr "accent-height" -accumulate = strAttr "accumulate" -additive = strAttr "additive" -alignment_baseline = strAttr "alignment-baseline" -alphabetic = fltAttr "alphabetic" -amplitude = fltAttr "amplitude" -arabic_form = strAttr "arabic-form" -ascent = fltAttr "ascent" -attributeName = strAttr "attributeName" -attributeType = strAttr "attributeType" -azimuth = fltAttr "azimuth" -baseFrequency = strAttr "baseFrequency" -baseProfile = strAttr "baseProfile" -baseline_shift = strAttr "baseline-shift" -bbox = strAttr "bbox" -begin = strAttr "begin" -bias = fltAttr "bias" -by = fltAttr "by" -calcMode = strAttr "calcMode" -cap_height = fltAttr "cap-height" -class_ = strAttr "class" -clip = strAttr "clip" -clip_path = strAttr "clip-path" -clip_rule = strAttr "clip-rule" -clipPathUnits = strAttr "clipPathUnits" -color = strAttr "color" -color_interpolation = strAttr "color-interpolation" -color_interpolation_filters = strAttr "color-interpolation-filters" -color_profile = strAttr "color-profile" -color_rendering = strAttr "color-rendering" -contentScriptType = strAttr "contentScriptType" -contentStyleType = strAttr "contentStyleType" -cursor = strAttr "cursor" -cx = strAttr "cx" -cy = strAttr "cy" -d = strAttr "d" -descent = fltAttr "descent" -diffuseConstant = fltAttr "diffuseConstant" -direction = strAttr "direction" -display = strAttr "display" -divisor = fltAttr "divisor" -dominant_baseline = strAttr "dominant-baseline" -dur = strAttr "dur" -dx = strAttr "dx" -dy = strAttr "dy" -edgeMode = strAttr "edgeMode" -elevation = fltAttr "elevation" -enable_background = strAttr "enable-background" -end = strAttr "end" -exponent = fltAttr "exponent" -externalResourcesRequired = strAttr "externalResourcesRequired" -fill = strAttr "fill" -fill_opacity = strAttr "fill-opacity" -fill_rule = strAttr "fill-rule" -filter = strAttr "filter" -filterRes = strAttr "filterRes" -filterUnits = strAttr "filterUnits" -flood_color = strAttr "flood-color" -flood_opacity = strAttr "flood-opacity" -font_family = strAttr "font-family" -font_size = strAttr "font-size" -font_size_adjust = strAttr "font-size-adjust" -font_stretch = strAttr "font-stretch" -font_style = strAttr "font-style" -font_variant = strAttr "font-variant" -font_weight = strAttr "font-weight" -format = strAttr "format" -from = fltAttr "from" -fx = strAttr "fx" -fy = strAttr "fy" -g1 = strAttr "g1" -g2 = strAttr "g2" -glyph_name = strAttr "glyph-name" -glyph_orientation_horizontal = strAttr "glyph-orientation-horizontal" -glyph_orientation_vertical = strAttr "glyph-orientation-vertical" -glyphRef = strAttr "glyphRef" -gradientTransform = strAttr "gradientTransform" -gradientUnits = strAttr "gradientUnits" -hanging = fltAttr "hanging" -height = strAttr "height" -horiz_adv_x = fltAttr "horiz-adv-x" -horiz_origin_x = fltAttr "horiz-origin-x" -horiz_origin_y = fltAttr "horiz-origin-y" -id = strAttr "id" -ideographic = fltAttr "ideographic" -image_rendering = strAttr "image-rendering" -in_ = strAttr "in" -in2 = strAttr "in2" -intercept = fltAttr "intercept" -k = fltAttr "k" -k1 = fltAttr "k1" -k2 = fltAttr "k2" -k3 = fltAttr "k3" -k4 = fltAttr "k4" -kernelMatrix = strAttr "kernelMatrix" -kernelUnitLength = strAttr "kernelUnitLength" -kerning = strAttr "kerning" -keyPoints = strAttr "keyPoints" -keySplines = strAttr "keySplines" -keyTimes = strAttr "keyTimes" -lang = strAttr "lang" -lengthAdjust = strAttr "lengthAdjust" -letter_spacing = strAttr "letter-spacing" -lighting_color = strAttr "lighting-color" -limitingConeAngle = fltAttr "limitingConeAngle" -local = strAttr "local" -marker_end = strAttr "marker-end" -marker_mid = strAttr "marker-mid" -marker_start = strAttr "marker-start" -markerHeight = strAttr "markerHeight" -markerUnits = strAttr "markerUnits" -markerWidth = strAttr "markerWidth" -mask = strAttr "mask" -maskContentUnits = strAttr "maskContentUnits" -maskUnits = strAttr "maskUnits" -mathematical = fltAttr "mathematical" -max = strAttr "max" -media = strAttr "media" -method = strAttr "method" -min = strAttr "min" -mode = strAttr "mode" -name = strAttr "name" -numOctaves = intAttr "numOctaves" -offset = fltAttr "offset" -onabort = strAttr "onabort" -onactivate = strAttr "onactivate" -onbegin = strAttr "onbegin" -onclick = strAttr "onclick" -onend = strAttr "onend" -onerror = strAttr "onerror" -onfocusin = strAttr "onfocusin" -onfocusout = strAttr "onfocusout" -onload = strAttr "onload" -onmousedown = strAttr "onmousedown" -onmousemove = strAttr "onmousemove" -onmouseout = strAttr "onmouseout" -onmouseover = strAttr "onmouseover" -onmouseup = strAttr "onmouseup" -onrepeat = strAttr "onrepeat" -onresize = strAttr "onresize" -onscroll = strAttr "onscroll" -onunload = strAttr "onunload" -onzoom = strAttr "onzoom" -opacity = strAttr "opacity" -operator = strAttr "operator" -order = strAttr "order" -orient = strAttr "orient" -orientation = strAttr "orientation" -origin = strAttr "origin" -overflow = strAttr "overflow" -overline_position = fltAttr "overline-position" -overline_thickness = fltAttr "overline-thickness" -panose_1 = intAttr "panose-1" -path = "path" --- path = strAttr "path" -pathLength = fltAttr "pathLength" -patternContentUnits = strAttr "patternContentUnits" -patternTransform = strAttr "patternTransform" -patternUnits = strAttr "patternUnits" -pointer_events = strAttr "pointer-events" -points = strAttr "points" -pointsAtX = fltAttr "pointsAtX" -pointsAtY = fltAttr "pointsAtY" -pointsAtZ = fltAttr "pointsAtZ" -preserveAlpha = strAttr "preserveAlpha" -preserveAspectRatio = strAttr "preserveAspectRatio" -primitiveUnits = strAttr "primitiveUnits" -r = strAttr "r" -radius = strAttr "radius" -refx = strAttr "refx" -refy = strAttr "refy" -rendering_intent = strAttr "rendering-intent" -repeatCount = strAttr "repeatCount" -repeatDur = strAttr "repeatDur" -requiredExtensions = strAttr "requiredExtensions" -requiredFeatures = strAttr "requiredFeatures" -restart = strAttr "restart" -result = strAttr "result" -rotate = strAttr "rotate" -rx = strAttr "rx" -ry = strAttr "ry" -scale = fltAttr "scale" -seed = fltAttr "seed" -shape_rendering = strAttr "shape-rendering" -slope = fltAttr "slope" -spacing = strAttr "spacing" -specularConstant = fltAttr "specularConstant" -specularExponent = fltAttr "specularExponent" -spreadMethod = strAttr "spreadMethod" -startOffset = strAttr "startOffset" -stdDeviation = strAttr "stdDeviation" -stemh = fltAttr "stemh" -stemv = fltAttr "stemv" -stitchTiles = strAttr "stitchTiles" -stop_color = strAttr "stop-color" -stop_opacity = strAttr "stop-opacity" -strikethrough_position = fltAttr "strikethrough-position" -strikethrough_thickness = fltAttr "strikethrough-thickness" -string = strAttr "string" -stroke = strAttr "stroke" -stroke_dasharray = strAttr "stroke-dasharray" -stroke_dashoffset = strAttr "stroke-dashoffset" -stroke_linecap = strAttr "stroke-linecap" -stroke_linejoin = strAttr "stroke-linejoin" -stroke_miterlimit = strAttr "stroke-miterlimit" -stroke_opacity = strAttr "stroke-opacity" -stroke_width = strAttr "stroke-width" -style = strAttr "style" -surfaceScale = fltAttr "surfaceScale" -systemLanguage = strAttr "systemLanguage" -tableValues = strAttr "tableValues" -target = strAttr "target" -targetX = fltAttr "targetX" -targetY = fltAttr "targetY" -text_anchor = strAttr "text-anchor" -text_decoration = strAttr "text-decoration" -text_rendering = strAttr "text-rendering" -textLength = strAttr "textLength" -title = strAttr "title" -to = fltAttr "to" -transform = strAttr "transform" -type_ = strAttr "type" -u1 = strAttr "u1" -u2 = strAttr "u2" -underline_position = fltAttr "underline-position" -underline_thickness = fltAttr "underline-thickness" -unicode = strAttr "unicode" -unicode_bidi = strAttr "unicode-bidi" -unicode_range = strAttr "unicode-range" -units_per_em = fltAttr "units-per-em" -v_alphabetic = fltAttr "v-alphabetic" -v_hanging = fltAttr "v-hanging" -v_ideographic = fltAttr "v-ideographic" -v_mathematical = fltAttr "v-mathematical" -values = strAttr "values" -version = fltAttr "version" -vert_adv_y = fltAttr "vert-adv-y" -vert_origin_x = fltAttr "vert-origin-x" -vert_origin_y = fltAttr "vert-origin-y" -viewBox = strAttr "viewBox" -viewTarget = strAttr "viewTarget" -visibility = strAttr "visibility" -width = strAttr "width" -widths = strAttr "widths" -word_spacing = strAttr "word-spacing" -writing_mode = strAttr "writing-mode" -x = strAttr "x" -x_height = fltAttr "x-height" -x1 = strAttr "x1" -x2 = strAttr "x2" -xChannelSelector = strAttr "xChannelSelector" -xlink_actuate = strAttr "xlink:actuate" -xlink_arcrole = strAttr "xlink:acrole" -xlink_href = strAttr "xlink:href" -xlink_role = strAttr "xlink:role" -xlink_show = strAttr "xlink:show" -xlink_title = strAttr "xlink:title" -xlink_type = strAttr "xlink:type" -xml_base = strAttr "xml:base" -xml_lang = strAttr "xml:lang" -xml_space = strAttr "xml:space" -y = strAttr "y" -y1 = strAttr "y1" -y2 = strAttr "y2" -yChannelSelector = strAttr "yChannelSelector" -z = fltAttr "z" -zoomAndPan = strAttr "zoomAndPan" +module Graphics.UI.Threepenny.SVG.Attributes ( + -- * Synopsis + -- | SVG attributes as defined by W3C, Scalable Vector Graphics (SVG) 1.1 + -- (Second Edition) Appendix M . + -- + -- Whenever possible, the Haskell identifier for an attribute is the + -- same as the attribute name. However, sometimes changes are necessary: + -- + -- 1. Hyphens @-@ are replaced by underscores @_@, e.g. 'stroke_width'. + -- + -- 2. An underscore is used whenever the attribute name conflicts with + -- a reserved word in Haskell, e.g. 'class_'. + + -- * Regular attributes + accent_height, accumulate, additive, alphabetic, amplitude, + arabic_form, ascent, attributeName, attributeType, azimuth, + baseFrequency, baseProfile, bbox, begin, bias, by, + calcMode, cap_height, class_, clipPathUnits, contentScriptType, + contentStyleType, cx, cy, + d, descent, diffuseConstant, divisor, dur, dx, dy, + edgeMode, elevation, end, exponent, externalResourcesRequired, + filterRes, filterUnits, format, from, fx, fy, + g1, g2, glyph_name, glyphRef, gradientTransform, gradientUnits, + hanging, height, horiz_adv_x, horiz_origin_x, horiz_origin_y, + id, ideographic, in_, in2, intercept, + k, k1, k2, k3, k4, kernelMatrix, kernelUnitLength, + keyPoints, keySplines, keyTimes, + lang, lengthAdjust, limitingConeAngle, local, + markerHeight, markerUnits, markerWidth, maskContentUnits, maskUnits, + mathematical, max, media, method, min, mode, + name, numOctaves, + offset, + onabort, onactivate, onbegin, onclick, onend, onerror, onfocusin, onfocusout, + onload, onmousedown, onmousemove, onmouseout, onmouseover, onmouseup, + onrepeat, onresize, onscroll, onunload, onzoom, + operator, order, orient, orientation, origin, + overline_position, overline_thickness, + panose_1, path, pathLength, patternContentUnits, + patternTransform, patternUnits, points, pointsAtX, pointsAtY, pointsAtZ, + preserveAlpha, preserveAspectRatio, primitiveUnits, + r, radius, refx, refy, rendering_intent, repeatCount, repeatDur, + requiredExtensions, requiredFeatures, restart, result, rotate, rx, ry, + scale, seed, slope, spacing, specularConstant, specularExponent, spreadMethod, + startOffset, stdDeviation, stemh, stemv, stitchTiles, + strikethrough_position, strikethrough_thickness, + string, style, surfaceScale, systemLanguage, + tableValues, target, targetX, targetY, textLength, title, to, transform, type_, + u1, u2, underline_position, underline_thickness, unicode, unicode_range, units_per_em, + v_alphabetic, v_hanging, v_ideographic, v_mathematical, values, version, + vert_adv_y, vert_origin_x, vert_origin_y, viewBox, viewTarget, + width, widths, + x, x_height, x1, x2, xChannelSelector, + xlink_actuate, xlink_arcrole, xlink_href, xlink_role, xlink_show, xlink_title, xlink_type, + xml_base, xml_lang, xml_space, + y, y1, y2, yChannelSelector, + z, zoomAndPan, + + -- * Presentation attributes + alignment_baseline, baseline_shift, + clip_path, clip_rule, clip, color_interpolation_filters, color_interpolation, + color_profile, color_rendering, color, cursor, + direction, display, dominant_baseline, + enable_background, + fill_opacity, fill_rule, fill, filter, flood_color,flood_opacity, + font_family, font_size_adjust, font_size, font_stretch, font_style, font_variant, + font_weight, + glyph_orientation_horizontal, glyph_orientation_vertical, + image_rendering, kerning, + letter_spacing, lighting_color, + marker_end, marker_mid, marker_start, mask, + opacity, overflow, pointer_events, + shape_rendering, stop_color, stop_opacity, + stroke_dasharray, stroke_dashoffset, stroke_linecap, stroke_linejoin, + stroke_miterlimit, stroke_opacity, stroke_width, stroke, + text_anchor, text_decoration, text_rendering, + unicode_bidi, visibility, word_spacing, writing_mode + ) where + + +import Graphics.UI.Threepenny.Core (Element, WriteAttr, attr, + mkWriteAttr, set') +import Prelude hiding (exponent, filter, id, max, + min) + +strAttr :: String -> WriteAttr Element String +strAttr n = mkWriteAttr (set' (attr n)) + +intAttr :: String -> WriteAttr Element Int +intAttr n = mkWriteAttr (set' (attr n) . show) + +fltAttr :: String -> WriteAttr Element Float +fltAttr n = mkWriteAttr (set' (attr n) . show) + +accent_height = fltAttr "accent-height" +accumulate = strAttr "accumulate" +additive = strAttr "additive" +alignment_baseline = strAttr "alignment-baseline" +alphabetic = fltAttr "alphabetic" +amplitude = fltAttr "amplitude" +arabic_form = strAttr "arabic-form" +ascent = fltAttr "ascent" +attributeName = strAttr "attributeName" +attributeType = strAttr "attributeType" +azimuth = fltAttr "azimuth" +baseFrequency = strAttr "baseFrequency" +baseProfile = strAttr "baseProfile" +baseline_shift = strAttr "baseline-shift" +bbox = strAttr "bbox" +begin = strAttr "begin" +bias = fltAttr "bias" +by = fltAttr "by" +calcMode = strAttr "calcMode" +cap_height = fltAttr "cap-height" +class_ = strAttr "class" +clip = strAttr "clip" +clip_path = strAttr "clip-path" +clip_rule = strAttr "clip-rule" +clipPathUnits = strAttr "clipPathUnits" +color = strAttr "color" +color_interpolation = strAttr "color-interpolation" +color_interpolation_filters = strAttr "color-interpolation-filters" +color_profile = strAttr "color-profile" +color_rendering = strAttr "color-rendering" +contentScriptType = strAttr "contentScriptType" +contentStyleType = strAttr "contentStyleType" +cursor = strAttr "cursor" +cx = strAttr "cx" +cy = strAttr "cy" +d = strAttr "d" +descent = fltAttr "descent" +diffuseConstant = fltAttr "diffuseConstant" +direction = strAttr "direction" +display = strAttr "display" +divisor = fltAttr "divisor" +dominant_baseline = strAttr "dominant-baseline" +dur = strAttr "dur" +dx = strAttr "dx" +dy = strAttr "dy" +edgeMode = strAttr "edgeMode" +elevation = fltAttr "elevation" +enable_background = strAttr "enable-background" +end = strAttr "end" +exponent = fltAttr "exponent" +externalResourcesRequired = strAttr "externalResourcesRequired" +fill = strAttr "fill" +fill_opacity = strAttr "fill-opacity" +fill_rule = strAttr "fill-rule" +filter = strAttr "filter" +filterRes = strAttr "filterRes" +filterUnits = strAttr "filterUnits" +flood_color = strAttr "flood-color" +flood_opacity = strAttr "flood-opacity" +font_family = strAttr "font-family" +font_size = strAttr "font-size" +font_size_adjust = strAttr "font-size-adjust" +font_stretch = strAttr "font-stretch" +font_style = strAttr "font-style" +font_variant = strAttr "font-variant" +font_weight = strAttr "font-weight" +format = strAttr "format" +from = fltAttr "from" +fx = strAttr "fx" +fy = strAttr "fy" +g1 = strAttr "g1" +g2 = strAttr "g2" +glyph_name = strAttr "glyph-name" +glyph_orientation_horizontal = strAttr "glyph-orientation-horizontal" +glyph_orientation_vertical = strAttr "glyph-orientation-vertical" +glyphRef = strAttr "glyphRef" +gradientTransform = strAttr "gradientTransform" +gradientUnits = strAttr "gradientUnits" +hanging = fltAttr "hanging" +height = strAttr "height" +horiz_adv_x = fltAttr "horiz-adv-x" +horiz_origin_x = fltAttr "horiz-origin-x" +horiz_origin_y = fltAttr "horiz-origin-y" +id = strAttr "id" +ideographic = fltAttr "ideographic" +image_rendering = strAttr "image-rendering" +in_ = strAttr "in" +in2 = strAttr "in2" +intercept = fltAttr "intercept" +k = fltAttr "k" +k1 = fltAttr "k1" +k2 = fltAttr "k2" +k3 = fltAttr "k3" +k4 = fltAttr "k4" +kernelMatrix = strAttr "kernelMatrix" +kernelUnitLength = strAttr "kernelUnitLength" +kerning = strAttr "kerning" +keyPoints = strAttr "keyPoints" +keySplines = strAttr "keySplines" +keyTimes = strAttr "keyTimes" +lang = strAttr "lang" +lengthAdjust = strAttr "lengthAdjust" +letter_spacing = strAttr "letter-spacing" +lighting_color = strAttr "lighting-color" +limitingConeAngle = fltAttr "limitingConeAngle" +local = strAttr "local" +marker_end = strAttr "marker-end" +marker_mid = strAttr "marker-mid" +marker_start = strAttr "marker-start" +markerHeight = strAttr "markerHeight" +markerUnits = strAttr "markerUnits" +markerWidth = strAttr "markerWidth" +mask = strAttr "mask" +maskContentUnits = strAttr "maskContentUnits" +maskUnits = strAttr "maskUnits" +mathematical = fltAttr "mathematical" +max = strAttr "max" +media = strAttr "media" +method = strAttr "method" +min = strAttr "min" +mode = strAttr "mode" +name = strAttr "name" +numOctaves = intAttr "numOctaves" +offset = fltAttr "offset" +onabort = strAttr "onabort" +onactivate = strAttr "onactivate" +onbegin = strAttr "onbegin" +onclick = strAttr "onclick" +onend = strAttr "onend" +onerror = strAttr "onerror" +onfocusin = strAttr "onfocusin" +onfocusout = strAttr "onfocusout" +onload = strAttr "onload" +onmousedown = strAttr "onmousedown" +onmousemove = strAttr "onmousemove" +onmouseout = strAttr "onmouseout" +onmouseover = strAttr "onmouseover" +onmouseup = strAttr "onmouseup" +onrepeat = strAttr "onrepeat" +onresize = strAttr "onresize" +onscroll = strAttr "onscroll" +onunload = strAttr "onunload" +onzoom = strAttr "onzoom" +opacity = strAttr "opacity" +operator = strAttr "operator" +order = strAttr "order" +orient = strAttr "orient" +orientation = strAttr "orientation" +origin = strAttr "origin" +overflow = strAttr "overflow" +overline_position = fltAttr "overline-position" +overline_thickness = fltAttr "overline-thickness" +panose_1 = intAttr "panose-1" +path = "path" +-- path = strAttr "path" +pathLength = fltAttr "pathLength" +patternContentUnits = strAttr "patternContentUnits" +patternTransform = strAttr "patternTransform" +patternUnits = strAttr "patternUnits" +pointer_events = strAttr "pointer-events" +points = strAttr "points" +pointsAtX = fltAttr "pointsAtX" +pointsAtY = fltAttr "pointsAtY" +pointsAtZ = fltAttr "pointsAtZ" +preserveAlpha = strAttr "preserveAlpha" +preserveAspectRatio = strAttr "preserveAspectRatio" +primitiveUnits = strAttr "primitiveUnits" +r = strAttr "r" +radius = strAttr "radius" +refx = strAttr "refx" +refy = strAttr "refy" +rendering_intent = strAttr "rendering-intent" +repeatCount = strAttr "repeatCount" +repeatDur = strAttr "repeatDur" +requiredExtensions = strAttr "requiredExtensions" +requiredFeatures = strAttr "requiredFeatures" +restart = strAttr "restart" +result = strAttr "result" +rotate = strAttr "rotate" +rx = strAttr "rx" +ry = strAttr "ry" +scale = fltAttr "scale" +seed = fltAttr "seed" +shape_rendering = strAttr "shape-rendering" +slope = fltAttr "slope" +spacing = strAttr "spacing" +specularConstant = fltAttr "specularConstant" +specularExponent = fltAttr "specularExponent" +spreadMethod = strAttr "spreadMethod" +startOffset = strAttr "startOffset" +stdDeviation = strAttr "stdDeviation" +stemh = fltAttr "stemh" +stemv = fltAttr "stemv" +stitchTiles = strAttr "stitchTiles" +stop_color = strAttr "stop-color" +stop_opacity = strAttr "stop-opacity" +strikethrough_position = fltAttr "strikethrough-position" +strikethrough_thickness = fltAttr "strikethrough-thickness" +string = strAttr "string" +stroke = strAttr "stroke" +stroke_dasharray = strAttr "stroke-dasharray" +stroke_dashoffset = strAttr "stroke-dashoffset" +stroke_linecap = strAttr "stroke-linecap" +stroke_linejoin = strAttr "stroke-linejoin" +stroke_miterlimit = strAttr "stroke-miterlimit" +stroke_opacity = strAttr "stroke-opacity" +stroke_width = strAttr "stroke-width" +style = strAttr "style" +surfaceScale = fltAttr "surfaceScale" +systemLanguage = strAttr "systemLanguage" +tableValues = strAttr "tableValues" +target = strAttr "target" +targetX = fltAttr "targetX" +targetY = fltAttr "targetY" +text_anchor = strAttr "text-anchor" +text_decoration = strAttr "text-decoration" +text_rendering = strAttr "text-rendering" +textLength = strAttr "textLength" +title = strAttr "title" +to = fltAttr "to" +transform = strAttr "transform" +type_ = strAttr "type" +u1 = strAttr "u1" +u2 = strAttr "u2" +underline_position = fltAttr "underline-position" +underline_thickness = fltAttr "underline-thickness" +unicode = strAttr "unicode" +unicode_bidi = strAttr "unicode-bidi" +unicode_range = strAttr "unicode-range" +units_per_em = fltAttr "units-per-em" +v_alphabetic = fltAttr "v-alphabetic" +v_hanging = fltAttr "v-hanging" +v_ideographic = fltAttr "v-ideographic" +v_mathematical = fltAttr "v-mathematical" +values = strAttr "values" +version = fltAttr "version" +vert_adv_y = fltAttr "vert-adv-y" +vert_origin_x = fltAttr "vert-origin-x" +vert_origin_y = fltAttr "vert-origin-y" +viewBox = strAttr "viewBox" +viewTarget = strAttr "viewTarget" +visibility = strAttr "visibility" +width = strAttr "width" +widths = strAttr "widths" +word_spacing = strAttr "word-spacing" +writing_mode = strAttr "writing-mode" +x = strAttr "x" +x_height = fltAttr "x-height" +x1 = strAttr "x1" +x2 = strAttr "x2" +xChannelSelector = strAttr "xChannelSelector" +xlink_actuate = strAttr "xlink:actuate" +xlink_arcrole = strAttr "xlink:acrole" +xlink_href = strAttr "xlink:href" +xlink_role = strAttr "xlink:role" +xlink_show = strAttr "xlink:show" +xlink_title = strAttr "xlink:title" +xlink_type = strAttr "xlink:type" +xml_base = strAttr "xml:base" +xml_lang = strAttr "xml:lang" +xml_space = strAttr "xml:space" +y = strAttr "y" +y1 = strAttr "y1" +y2 = strAttr "y2" +yChannelSelector = strAttr "yChannelSelector" +z = fltAttr "z" +zoomAndPan = strAttr "zoomAndPan" diff --git a/src/Graphics/UI/Threepenny/SVG/Elements.hs b/src/Graphics/UI/Threepenny/SVG/Elements.hs --- a/src/Graphics/UI/Threepenny/SVG/Elements.hs +++ b/src/Graphics/UI/Threepenny/SVG/Elements.hs @@ -1,124 +1,124 @@ -module Graphics.UI.Threepenny.SVG.Elements ( - -- * Synopsis - -- | SVG elements as defined by W3C, Scalable Vector Graphics (SVG) 1.1 - -- (Second Edition) Appendix M . - -- - -- Whenever possible, the Haskell identifier for an element is the - -- same as the attribute name. However, sometimes changes are necessary: - -- - -- 1. Hyphens @-@ are replaced by underscores @_@, e.g. 'font_face'. - - -- * SVG Elements - a, altGlyph, altGlyphDef, altGlyphItem, - animate, animateColor, animateMotion, animateTransform, - circle, clipPath, colorProfile, cursor, - defs, desc, - ellipse, - feBlend, feColorMatrix, feComponentTransfer, feComposite, feConvolveMatrix, - feDiffuseLighting, feDisplacementMap, feDistantLight, feFlood, - feFuncA, feFuncB, feFuncG, feFuncR, - feGaussianBlur, feImage, feMerge, feMergeNode, feMorphology, feOffset, - fePointLight, feSpecularLighting, feSpotLight, feTile, feTurbulence, - filter, font, - font_face, font_face_format, font_face_name, font_face_srv, font_face_uri, - foreignObject, - g, glyph, glyphRef, - hkern, - image, - line, linearGradient, - marker, mask, metadata, missing_glyph, mpath, - path, pattern, polygon, polyline, - radialGradient, rect, - script, set, stop, style, svg, switch, symbol, - text, textPath, title, tref, tspan, - use, - view, vkern, - ) where - -import Prelude (Maybe(..)) -import Graphics.UI.Threepenny.Core (mkElementNamespace) - - -tag = mkElementNamespace (Just "http://www.w3.org/2000/svg") -itag = tag - -a = tag "a" -altGlyph = tag "altGlyph" -altGlyphDef = itag "altGlyphDef" -altGlyphItem = itag "altGlyphItem" -animate = tag "animate" -animateColor = tag "animateColor" -animateMotion = tag "animateMotion" -animateTransform = itag "animateTransform" -circle = itag "circle" -clipPath = tag "clipPath" -colorProfile = itag "colorProfile" -cursor = itag "cursor" -defs = tag "defs" -desc = itag "desc" -ellipse = tag "ellipse" -feBlend = tag "feBlend" -feColorMatrix = tag "feColorMatrix" -feComponentTransfer = tag "feComponentTransfer" -feComposite = tag "feComposite" -feConvolveMatrix = tag "feConvolveMatrix" -feDiffuseLighting = tag "feDiffuseLighting" -feDisplacementMap = tag "feDisplacementMap" -feDistantLight = itag "feDistantLight" -feFlood = tag "feFlood" -feFuncA = itag "feFuncA" -feFuncB = itag "feFuncB" -feFuncG = itag "feFuncG" -feFuncR = itag "feFuncR" -feGaussianBlur = tag "feGaussianBlur" -feImage = tag "feImage" -feMerge = tag "feMerge" -feMergeNode = itag "feMergeNode" -feMorphology = tag "feMorphology" -feOffset = tag "feOffset" -fePointLight = itag "fePointLight" -feSpecularLighting = tag "feSpecularLighting" -feSpotLight = itag "feSpotLight" -feTile = tag "feTile" -feTurbulence = tag "feTurbulence" -filter = tag "filter" -font = tag "font" -font_face = itag "font-face" -font_face_format = itag "font-face-format" -font_face_name = itag "font-face-name" -font_face_srv = itag "font-face-src" -font_face_uri = itag "font-face-uri" -foreignObject = tag "foreignObject" -g = tag "g" -glyph = tag "glyph" -glyphRef = tag "glyphRef" -hkern = itag "hkern" -image = tag "image" -line = tag "line" -linearGradient = tag "linearGradient" -marker = tag "marker" -mask = tag "mask" -metadata = itag "metadata" -missing_glyph = tag "missing-glyph" -mpath = itag "mpath" -path = itag "path" -pattern = tag "pattern" -polygon = tag "polygon" -polyline = tag "polyline" -radialGradient = tag "radialGradient" -rect = tag "rect" -script = itag "script" -set = itag "set" -stop = tag "stop" -style = itag "style" -svg = tag "svg" -switch = tag "switch" -symbol = tag "symbol" -text = tag "text" -textPath = tag "textPath" -title = itag "title" -tref = tag "tref" -tspan = tag "tspan" -use = tag "use" -view = itag "view" -vkern = itag "vkern" +module Graphics.UI.Threepenny.SVG.Elements ( + -- * Synopsis + -- | SVG elements as defined by W3C, Scalable Vector Graphics (SVG) 1.1 + -- (Second Edition) Appendix M . + -- + -- Whenever possible, the Haskell identifier for an element is the + -- same as the attribute name. However, sometimes changes are necessary: + -- + -- 1. Hyphens @-@ are replaced by underscores @_@, e.g. 'font_face'. + + -- * SVG Elements + a, altGlyph, altGlyphDef, altGlyphItem, + animate, animateColor, animateMotion, animateTransform, + circle, clipPath, colorProfile, cursor, + defs, desc, + ellipse, + feBlend, feColorMatrix, feComponentTransfer, feComposite, feConvolveMatrix, + feDiffuseLighting, feDisplacementMap, feDistantLight, feFlood, + feFuncA, feFuncB, feFuncG, feFuncR, + feGaussianBlur, feImage, feMerge, feMergeNode, feMorphology, feOffset, + fePointLight, feSpecularLighting, feSpotLight, feTile, feTurbulence, + filter, font, + font_face, font_face_format, font_face_name, font_face_srv, font_face_uri, + foreignObject, + g, glyph, glyphRef, + hkern, + image, + line, linearGradient, + marker, mask, metadata, missing_glyph, mpath, + path, pattern, polygon, polyline, + radialGradient, rect, + script, set, stop, style, svg, switch, symbol, + text, textPath, title, tref, tspan, + use, + view, vkern, + ) where + +import Prelude (Maybe(..)) +import Graphics.UI.Threepenny.Core (mkElementNamespace) + + +tag = mkElementNamespace (Just "http://www.w3.org/2000/svg") +itag = tag + +a = tag "a" +altGlyph = tag "altGlyph" +altGlyphDef = itag "altGlyphDef" +altGlyphItem = itag "altGlyphItem" +animate = tag "animate" +animateColor = tag "animateColor" +animateMotion = tag "animateMotion" +animateTransform = itag "animateTransform" +circle = itag "circle" +clipPath = tag "clipPath" +colorProfile = itag "colorProfile" +cursor = itag "cursor" +defs = tag "defs" +desc = itag "desc" +ellipse = tag "ellipse" +feBlend = tag "feBlend" +feColorMatrix = tag "feColorMatrix" +feComponentTransfer = tag "feComponentTransfer" +feComposite = tag "feComposite" +feConvolveMatrix = tag "feConvolveMatrix" +feDiffuseLighting = tag "feDiffuseLighting" +feDisplacementMap = tag "feDisplacementMap" +feDistantLight = itag "feDistantLight" +feFlood = tag "feFlood" +feFuncA = itag "feFuncA" +feFuncB = itag "feFuncB" +feFuncG = itag "feFuncG" +feFuncR = itag "feFuncR" +feGaussianBlur = tag "feGaussianBlur" +feImage = tag "feImage" +feMerge = tag "feMerge" +feMergeNode = itag "feMergeNode" +feMorphology = tag "feMorphology" +feOffset = tag "feOffset" +fePointLight = itag "fePointLight" +feSpecularLighting = tag "feSpecularLighting" +feSpotLight = itag "feSpotLight" +feTile = tag "feTile" +feTurbulence = tag "feTurbulence" +filter = tag "filter" +font = tag "font" +font_face = itag "font-face" +font_face_format = itag "font-face-format" +font_face_name = itag "font-face-name" +font_face_srv = itag "font-face-src" +font_face_uri = itag "font-face-uri" +foreignObject = tag "foreignObject" +g = tag "g" +glyph = tag "glyph" +glyphRef = tag "glyphRef" +hkern = itag "hkern" +image = tag "image" +line = tag "line" +linearGradient = tag "linearGradient" +marker = tag "marker" +mask = tag "mask" +metadata = itag "metadata" +missing_glyph = tag "missing-glyph" +mpath = itag "mpath" +path = itag "path" +pattern = tag "pattern" +polygon = tag "polygon" +polyline = tag "polyline" +radialGradient = tag "radialGradient" +rect = tag "rect" +script = itag "script" +set = itag "set" +stop = tag "stop" +style = itag "style" +svg = tag "svg" +switch = tag "switch" +symbol = tag "symbol" +text = tag "text" +textPath = tag "textPath" +title = itag "title" +tref = tag "tref" +tspan = tag "tspan" +use = tag "use" +view = itag "view" +vkern = itag "vkern" diff --git a/src/Graphics/UI/Threepenny/Timer.hs b/src/Graphics/UI/Threepenny/Timer.hs --- a/src/Graphics/UI/Threepenny/Timer.hs +++ b/src/Graphics/UI/Threepenny/Timer.hs @@ -1,90 +1,90 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} - -module Graphics.UI.Threepenny.Timer ( - -- * Synopsis - -- | Implementation of a simple timer which runs on the server-side. - -- - -- NOTE: The timer may be rather wobbly unless you compile - -- with the @-threaded@ option. - - -- * Documentation - Timer, timer, - interval, running, tick, start, stop, - ) where - -import Data.Typeable -import Control.Monad (when, forever, void) -import Control.Concurrent -import Control.Concurrent.STM -import Reactive.Threepenny - -import Graphics.UI.Threepenny.Core - - -data Timer = Timer - { tRunning :: GetSet Bool Bool - , tInterval :: GetSet Int Int -- in ms - , tTick :: Event () - } deriving (Typeable) - --- | Create a new timer -timer :: UI Timer -timer = liftIO $ do - tvRunning <- newTVarIO False - tvInterval <- newTVarIO 1000 - (tTick, fire) <- newEvent - - forkIO $ forever $ do - atomically $ do - b <- readTVar tvRunning - when (not b) retry - wait <- atomically $ readTVar tvInterval - fire () - threadDelay (wait * 1000) - - let tRunning = fromTVar tvRunning - tInterval = fromTVar tvInterval - - return $ Timer {..} - --- | Timer event. -tick :: Timer -> Event () -tick = tTick - --- | Timer interval in milliseconds. -interval :: Attr Timer Int -interval = fromGetSet tInterval - --- | Whether the timer is running or not. -running :: Attr Timer Bool -running = fromGetSet tRunning - --- | Start the timer. -start :: Timer -> UI () -start = set' running True - --- | Stop the timer. -stop :: Timer -> UI () -stop = set' running False - -fromTVar :: TVar a -> GetSet a a -fromTVar var = (atomically $ readTVar var, atomically . writeTVar var) - -type GetSet i o = (IO o, i -> IO ()) - -fromGetSet :: (x -> GetSet i o) -> ReadWriteAttr x i o -fromGetSet f = mkReadWriteAttr (liftIO . fst . f) (\i x -> liftIO $ snd (f x) i) - - -{----------------------------------------------------------------------------- - Small test -------------------------------------------------------------------------------} -{- - -testTimer = do - t <- timer - void $ register (tick t) $ const $ putStr "Hello" - return t - # set interval 1000 - # set running True --} +{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} + +module Graphics.UI.Threepenny.Timer ( + -- * Synopsis + -- | Implementation of a simple timer which runs on the server-side. + -- + -- NOTE: The timer may be rather wobbly unless you compile + -- with the @-threaded@ option. + + -- * Documentation + Timer, timer, + interval, running, tick, start, stop, + ) where + +import Data.Typeable +import Control.Monad (when, forever, void) +import Control.Concurrent +import Control.Concurrent.STM +import Reactive.Threepenny + +import Graphics.UI.Threepenny.Core + + +data Timer = Timer + { tRunning :: GetSet Bool Bool + , tInterval :: GetSet Int Int -- in ms + , tTick :: Event () + } deriving (Typeable) + +-- | Create a new timer +timer :: UI Timer +timer = liftIO $ do + tvRunning <- newTVarIO False + tvInterval <- newTVarIO 1000 + (tTick, fire) <- newEvent + + forkIO $ forever $ do + atomically $ do + b <- readTVar tvRunning + when (not b) retry + wait <- atomically $ readTVar tvInterval + fire () + threadDelay (wait * 1000) + + let tRunning = fromTVar tvRunning + tInterval = fromTVar tvInterval + + return $ Timer {..} + +-- | Timer event. +tick :: Timer -> Event () +tick = tTick + +-- | Timer interval in milliseconds. +interval :: Attr Timer Int +interval = fromGetSet tInterval + +-- | Whether the timer is running or not. +running :: Attr Timer Bool +running = fromGetSet tRunning + +-- | Start the timer. +start :: Timer -> UI () +start = set' running True + +-- | Stop the timer. +stop :: Timer -> UI () +stop = set' running False + +fromTVar :: TVar a -> GetSet a a +fromTVar var = (atomically $ readTVar var, atomically . writeTVar var) + +type GetSet i o = (IO o, i -> IO ()) + +fromGetSet :: (x -> GetSet i o) -> ReadWriteAttr x i o +fromGetSet f = mkReadWriteAttr (liftIO . fst . f) (\i x -> liftIO $ snd (f x) i) + + +{----------------------------------------------------------------------------- + Small test +------------------------------------------------------------------------------} +{- + +testTimer = do + t <- timer + void $ register (tick t) $ const $ putStr "Hello" + return t + # set interval 1000 + # set running True +-} diff --git a/src/Graphics/UI/Threepenny/Widgets.hs b/src/Graphics/UI/Threepenny/Widgets.hs --- a/src/Graphics/UI/Threepenny/Widgets.hs +++ b/src/Graphics/UI/Threepenny/Widgets.hs @@ -1,119 +1,119 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} -module Graphics.UI.Threepenny.Widgets ( - -- * Synopsis - -- | Widgets are reusable building blocks for a graphical user interface. - -- This module collects useful widgets that are designed to work - -- with functional reactive programming (FRP). - -- - -- For more details and information on how to write your own widgets, see the - -- . - - -- * Tidings - Tidings, rumors, facts, tidings, - -- * Widgets - -- ** Input widgets - TextEntry, entry, userText, - -- ** ListBox - ListBox, listBox, userSelection, - ) where - -import Control.Monad (void, when) -import qualified Data.Map as Map - -import qualified Graphics.UI.Threepenny.Attributes as UI -import qualified Graphics.UI.Threepenny.Events as UI -import qualified Graphics.UI.Threepenny.Elements as UI -import Graphics.UI.Threepenny.Core -import Reactive.Threepenny - -{----------------------------------------------------------------------------- - Input widgets -------------------------------------------------------------------------------} --- | A single-line text entry. -data TextEntry = TextEntry - { _elementTE :: Element - , _userTE :: Tidings String - } - -instance Widget TextEntry where getElement = _elementTE - --- | User changes to the text value. -userText :: TextEntry -> Tidings String -userText = _userTE - --- | Create a single-line text entry. -entry - :: Behavior String -- ^ Display value when the element does not have focus. - -> UI TextEntry -entry bValue = do -- single text entry - input <- UI.input - - bEditing <- stepper False $ and <$> - unions [True <$ UI.focus input, False <$ UI.blur input] - - window <- askWindow - liftIOLater $ onChange bValue $ \s -> runUI window $ do - editing <- liftIO $ currentValue bEditing - when (not editing) $ void $ element input # set value s - - let _elementTE = input - _userTE = tidings bValue $ UI.valueChange input - return TextEntry {..} - -{----------------------------------------------------------------------------- - List box -------------------------------------------------------------------------------} --- | A list of values. The user can select entries. -data ListBox a = ListBox - { _elementLB :: Element - , _selectionLB :: Tidings (Maybe a) - } - -instance Widget (ListBox a) where getElement = _elementLB - --- | User changes to the current selection (possibly empty). -userSelection :: ListBox a -> Tidings (Maybe a) -userSelection = _selectionLB - --- | Create a 'ListBox'. -listBox :: forall a. Ord a - => Behavior [a] -- ^ list of items - -> Behavior (Maybe a) -- ^ selected item - -> Behavior (a -> UI Element) -- ^ display for an item - -> UI (ListBox a) -listBox bitems bsel bdisplay = do - list <- UI.select - - -- animate output items - element list # sink items (map <$> bdisplay <*> bitems) - - -- animate output selection - let bindices :: Behavior (Map.Map a Int) - bindices = (Map.fromList . flip zip [0..]) <$> bitems - bindex = lookupIndex <$> bindices <*> bsel - - lookupIndex indices Nothing = Nothing - lookupIndex indices (Just sel) = Map.lookup sel indices - - element list # sink UI.selection bindex - - -- changing the display won't change the current selection - -- eDisplay <- changes display - -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ] - - -- user selection - let bindices2 :: Behavior (Map.Map Int a) - bindices2 = Map.fromList . zip [0..] <$> bitems - - _selectionLB = tidings bsel $ - lookupIndex <$> bindices2 <@> UI.selectionChange list - _elementLB = list - - return ListBox {..} - -items = mkWriteAttr $ \i x -> void $ do - return x # set children [] #+ map (\i -> UI.option #+ [i]) i - - - - +{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} +module Graphics.UI.Threepenny.Widgets ( + -- * Synopsis + -- | Widgets are reusable building blocks for a graphical user interface. + -- This module collects useful widgets that are designed to work + -- with functional reactive programming (FRP). + -- + -- For more details and information on how to write your own widgets, see the + -- . + + -- * Tidings + Tidings, rumors, facts, tidings, + -- * Widgets + -- ** Input widgets + TextEntry, entry, userText, + -- ** ListBox + ListBox, listBox, userSelection, + ) where + +import Control.Monad (void, when) +import qualified Data.Map as Map + +import qualified Graphics.UI.Threepenny.Attributes as UI +import qualified Graphics.UI.Threepenny.Events as UI +import qualified Graphics.UI.Threepenny.Elements as UI +import Graphics.UI.Threepenny.Core +import Reactive.Threepenny + +{----------------------------------------------------------------------------- + Input widgets +------------------------------------------------------------------------------} +-- | A single-line text entry. +data TextEntry = TextEntry + { _elementTE :: Element + , _userTE :: Tidings String + } + +instance Widget TextEntry where getElement = _elementTE + +-- | User changes to the text value. +userText :: TextEntry -> Tidings String +userText = _userTE + +-- | Create a single-line text entry. +entry + :: Behavior String -- ^ Display value when the element does not have focus. + -> UI TextEntry +entry bValue = do -- single text entry + input <- UI.input + + bEditing <- stepper False $ and <$> + unions [True <$ UI.focus input, False <$ UI.blur input] + + window <- askWindow + liftIOLater $ onChange bValue $ \s -> runUI window $ do + editing <- liftIO $ currentValue bEditing + when (not editing) $ void $ element input # set value s + + let _elementTE = input + _userTE = tidings bValue $ UI.valueChange input + return TextEntry {..} + +{----------------------------------------------------------------------------- + List box +------------------------------------------------------------------------------} +-- | A list of values. The user can select entries. +data ListBox a = ListBox + { _elementLB :: Element + , _selectionLB :: Tidings (Maybe a) + } + +instance Widget (ListBox a) where getElement = _elementLB + +-- | User changes to the current selection (possibly empty). +userSelection :: ListBox a -> Tidings (Maybe a) +userSelection = _selectionLB + +-- | Create a 'ListBox'. +listBox :: forall a. Ord a + => Behavior [a] -- ^ list of items + -> Behavior (Maybe a) -- ^ selected item + -> Behavior (a -> UI Element) -- ^ display for an item + -> UI (ListBox a) +listBox bitems bsel bdisplay = do + list <- UI.select + + -- animate output items + element list # sink items (map <$> bdisplay <*> bitems) + + -- animate output selection + let bindices :: Behavior (Map.Map a Int) + bindices = (Map.fromList . flip zip [0..]) <$> bitems + bindex = lookupIndex <$> bindices <*> bsel + + lookupIndex indices Nothing = Nothing + lookupIndex indices (Just sel) = Map.lookup sel indices + + element list # sink UI.selection bindex + + -- changing the display won't change the current selection + -- eDisplay <- changes display + -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ] + + -- user selection + let bindices2 :: Behavior (Map.Map Int a) + bindices2 = Map.fromList . zip [0..] <$> bitems + + _selectionLB = tidings bsel $ + lookupIndex <$> bindices2 <@> UI.selectionChange list + _elementLB = list + + return ListBox {..} + +items = mkWriteAttr $ \i x -> void $ do + return x # set children [] #+ map (\i -> UI.option #+ [i]) i + + + + diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs --- a/src/Reactive/Threepenny.hs +++ b/src/Reactive/Threepenny.hs @@ -1,395 +1,395 @@ -{-# LANGUAGE RecursiveDo #-} -module Reactive.Threepenny ( - -- * Synopsis - -- | Functional reactive programming. - - -- * Types - -- $intro - Event, Behavior, - - -- * IO - -- | Functions to connect events to the outside world. - Handler, newEvent, register, - currentValue, - - -- * Core Combinators - -- | Minimal set of combinators for programming with 'Event' and 'Behavior'. - module Control.Applicative, - never, filterJust, unionWith, - accumE, apply, stepper, - -- $classes - - -- * Derived Combinators - -- | Additional combinators that make programming - -- with 'Event' and 'Behavior' convenient. - -- ** Application - (<@>), (<@), - -- ** Filtering - filterE, filterApply, whenE, split, - -- ** Union - unions, concatenate, - -- ** Accumulation - -- $accumulation - accumB, mapAccum, - - -- * Additional Notes - -- $recursion - - -- * Tidings - Tidings, tidings, facts, rumors, - - -- * Internal - -- | Functions reserved for special circumstances. - -- Do not use unless you know what you're doing. - onChange, unsafeMapIO, newEventsNamed, - ) where - -import Control.Applicative -import Control.Monad (void) -import Control.Monad.IO.Class -import Data.IORef -import qualified Data.Map as Map - -import Reactive.Threepenny.Memo as Memo -import qualified Reactive.Threepenny.PulseLatch as Prim - -type Pulse = Prim.Pulse -type Latch = Prim.Latch -type Map = Map.Map - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} -{- $intro - -At its core, Functional Reactive Programming (FRP) is about two -data types 'Event' and 'Behavior' and the various ways to combine them. - --} - -{-| @Event a@ represents a stream of events as they occur in time. -Semantically, you can think of @Event a@ as an infinite list of values -that are tagged with their corresponding time of occurence, - -> type Event a = [(Time,a)] --} -newtype Event a = E { unE :: Memo (Pulse a) } - -{-| @Behavior a@ represents a value that varies in time. Think of it as - -> type Behavior a = Time -> a --} -data Behavior a = B { latch :: Latch a, changes :: Event () } - -{----------------------------------------------------------------------------- - IO -------------------------------------------------------------------------------} --- | An /event handler/ is a function that takes an --- /event value/ and performs some computation. -type Handler a = a -> IO () - --- | Create a new event. --- Also returns a function that triggers an event occurrence. -newEvent :: IO (Event a, Handler a) -newEvent = do - (p, fire) <- Prim.newPulse - return (E $ fromPure p, fire) - - --- | Create a series of events with delayed initialization. --- --- For each name, the initialization handler will be called --- exactly once when the event is first "brought to life", --- e.g. when an event handler is registered to it. -newEventsNamed :: Ord name - => Handler (name, Event a, Handler a) -- ^ Initialization procedure. - -> IO (name -> Event a) -- ^ Series of events. -newEventsNamed init = do - eventsRef <- newIORef Map.empty - return $ \name -> E $ memoize $ do - events <- readIORef eventsRef - case Map.lookup name events of - Just p -> return p - Nothing -> do - (p, fire) <- Prim.newPulse - writeIORef eventsRef $ Map.insert name p events - init (name, E $ fromPure p, fire) - return p - - --- | Register an event 'Handler' for an 'Event'. --- All registered handlers will be called whenever the event occurs. --- --- When registering an event handler, you will also be given an action --- that unregisters this handler again. --- --- > do unregisterMyHandler <- register event myHandler --- --- FIXME: Unregistering event handlers does not work yet. -register :: Event a -> Handler a -> IO (IO ()) -register e h = do - p <- at (unE e) -- evaluate the memoized action - Prim.addHandler p h - --- | Register an event 'Handler' for a 'Behavior'. --- All registered handlers will be called whenever the behavior changes. --- --- However, note that this is only an approximation, --- as behaviors may change continuously. --- Consequently, handlers should be idempotent. -onChange :: Behavior a -> Handler a -> IO () -onChange (B l e) h = void $ do - -- This works because latches are updated before the handlers are being called. - register e (\_ -> h =<< Prim.readLatch l) - --- | Read the current value of a 'Behavior'. -currentValue :: MonadIO m => Behavior a -> m a -currentValue (B l _) = liftIO $ Prim.readLatch l - - -{----------------------------------------------------------------------------- - Core Combinators -------------------------------------------------------------------------------} -instance Functor Event where - fmap f e = E $ liftMemo1 (Prim.mapP f) (unE e) - -unsafeMapIO :: (a -> IO b) -> Event a -> Event b -unsafeMapIO f e = E $ liftMemo1 (Prim.unsafeMapIOP f) (unE e) - --- | Event that never occurs. --- Think of it as @never = []@. -never :: Event a -never = E $ fromPure Prim.neverP - --- | Return all event occurrences that are 'Just' values, discard the rest. --- Think of it as --- --- > filterJust es = [(time,a) | (time,Just a) <- es] -filterJust e = E $ liftMemo1 Prim.filterJustP (unE e) - --- | Merge two event streams of the same type. --- In case of simultaneous occurrences, the event values are combined --- with the binary function. --- Think of it as --- --- > unionWith f ((timex,x):xs) ((timey,y):ys) --- > | timex == timey = (timex,f x y) : unionWith f xs ys --- > | timex < timey = (timex,x) : unionWith f xs ((timey,y):ys) --- > | timex > timey = (timey,y) : unionWith f ((timex,x):xs) ys -unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a -unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2) - --- | Apply a time-varying function to a stream of events. --- Think of it as --- --- > apply bf ex = [(time, bf time x) | (time, x) <- ex] -apply :: Behavior (a -> b) -> Event a -> Event b -apply f x = E $ liftMemo1 (\p -> Prim.applyP (latch f) p) (unE x) - -infixl 4 <@>, <@ - --- | Infix synonym for 'apply', similar to '<*>'. -(<@>) :: Behavior (a -> b) -> Event a -> Event b -(<@>) = apply - --- | Variant of 'apply' similar to '<*' -(<@) :: Behavior a -> Event b -> Event a -b <@ e = (const <$> b) <@> e - --- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. --- It starts with an initial value and combines it with incoming events. --- For example, think --- --- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] --- > = stepper "x" [(time1,"xy"),(time2,"xyz")] --- --- Note that the value of the behavior changes \"slightly after\" --- the events occur. This allows for recursive definitions. -accumB :: MonadIO m => a -> Event (a -> a) -> m (Behavior a) -accumB a e = liftIO $ do - (l1,p1) <- Prim.accumL a =<< at (unE e) - p2 <- Prim.mapP (const ()) p1 - return $ B l1 (E $ fromPure p2) - - --- | Construct a time-varying function from an initial value and --- a stream of new values. Think of it as --- --- > stepper x0 ex = return $ \time -> --- > last (x0 : [x | (timex,x) <- ex, timex < time]) --- --- Note that the smaller-than-sign in the comparision @timex < time@ means --- that the value of the behavior changes \"slightly after\" --- the event occurrences. This allows for recursive definitions. -stepper :: MonadIO m => a -> Event a -> m (Behavior a) -stepper a e = accumB a (const <$> e) - --- | The 'accumE' function accumulates a stream of events. --- Example: --- --- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] --- > = return [(time1,"xy"),(time2,"xyz")] --- --- Note that the output events are simultaneous with the input events, --- there is no \"delay\" like in the case of 'accumB'. -accumE :: MonadIO m => a -> Event (a -> a) -> m (Event a) -accumE a e = liftIO $ do - p <- fmap snd . Prim.accumL a =<< at (unE e) - return $ E $ fromPure p - -instance Functor Behavior where - fmap f ~(B l e) = B (Prim.mapL f l) e - -instance Applicative Behavior where - pure a = B (Prim.pureL a) never - ~(B lf ef) <*> ~(B lx ex) = - B (Prim.applyL lf lx) (unionWith const ef ex) - -{- $classes - -/Further combinators that Haddock can't document properly./ - -> instance Applicative Behavior - -'Behavior' is an applicative functor. In particular, we have the following functions. - -> pure :: a -> Behavior a - -The constant time-varying value. Think of it as @pure x = \\time -> x@. - -> (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b - -Combine behaviors in applicative style. -Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. - --} - -{- $recursion - -Recursion in the 'IO' monad is possible, but somewhat limited. -The main rule is that the sequence of IO actions must be known -in advance, only the values may be recursive. - -Good: - -> mdo -> let e2 = apply (const <$> b) e1 -- applying a behavior is not an IO action -> b <- accumB $ (+1) <$ e2 - -Bad: - -> mdo -> b <- accumB $ (+1) <$ e2 -- actions executed here could depend ... -> let e2 = apply (const <$> b) e1 -- ... on this value - --} - -{----------------------------------------------------------------------------- - Derived Combinators -------------------------------------------------------------------------------} --- | Return all event occurrences that fulfill the predicate, discard the rest. -filterE :: (a -> Bool) -> Event a -> Event a -filterE p = filterJust . fmap (\a -> if p a then Just a else Nothing) - --- | Return all event occurrences that fulfill the time-varying predicate, --- discard the rest. Generalization of 'filterE'. -filterApply :: Behavior (a -> Bool) -> Event a -> Event a -filterApply bp = fmap snd . filterE fst . apply ((\p a -> (p a,a)) <$> bp) - --- | Return event occurrences only when the behavior is 'True'. --- Variant of 'filterApply'. -whenE :: Behavior Bool -> Event a -> Event a -whenE bf = filterApply (const <$> bf) - --- | Split event occurrences according to a tag. --- The 'Left' values go into the left component while the 'Right' values --- go into the right component of the result. -split :: Event (Either a b) -> (Event a, Event b) -split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) - where - fromLeft (Left a) = Just a - fromLeft (Right b) = Nothing - fromRight (Left a) = Nothing - fromRight (Right b) = Just b - --- | Collect simultaneous event occurrences in a list. -unions :: [Event a] -> Event [a] -unions = foldr (unionWith (++)) never . map (fmap (:[])) - --- | Apply a list of functions in succession. --- Useful in conjunction with 'unions'. --- --- > concatenate [f,g,h] = f . g . h -concatenate :: [a -> a] -> (a -> a) -concatenate = foldr (.) id - -{- $accumulation - -Note: All accumulation functions are strict in the accumulated value! -acc -> (x,acc) is the order used by 'unfoldr' and 'State'. - --} - --- | Efficient combination of 'accumE' and 'accumB'. -mapAccum :: MonadIO m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc) -mapAccum acc ef = do - e <- accumE (undefined,acc) ((. snd) <$> ef) - b <- stepper acc (snd <$> e) - return (fst <$> e, b) - - -{----------------------------------------------------------------------------- - Tidings - - Data type for combining user events. - See - for more information. -------------------------------------------------------------------------------} --- | Data type representing a behavior ('facts') --- and suggestions to change it ('rumors'). -data Tidings a = T { facts :: Behavior a, rumors :: Event a } - --- | Smart constructor. Combine facts and rumors into 'Tidings'. -tidings :: Behavior a -> Event a -> Tidings a -tidings b e = T b e - -instance Functor Tidings where - fmap f (T b e) = T (fmap f b) (fmap f e) - --- | The applicative instance combines 'rumors' --- and uses 'facts' when some of the 'rumors' are not available. -instance Applicative Tidings where - pure x = T (pure x) never - f <*> x = uncurry ($) <$> pair f x - -pair :: Tidings a -> Tidings b -> Tidings (a,b) -pair (T bx ex) (T by ey) = T b e - where - b = (,) <$> bx <*> by - x = flip (,) <$> by <@> ex - y = (,) <$> bx <@> ey - e = unionWith (\(x,_) (_,y) -> (x,y)) x y - - -{----------------------------------------------------------------------------- - Test -------------------------------------------------------------------------------} -test :: IO (Int -> IO ()) -test = do - (e1,fire) <- newEvent - e2 <- accumE 0 $ (+) <$> e1 - _ <- register e2 print - - return fire - -test_recursion1 :: IO (IO ()) -test_recursion1 = mdo - (e1, fire) <- newEvent - let e2 :: Event Int - e2 = apply (const <$> b) e1 - b <- accumB 0 $ (+1) <$ e2 - _ <- register e2 print - - return $ fire () - - +{-# LANGUAGE RecursiveDo #-} +module Reactive.Threepenny ( + -- * Synopsis + -- | Functional reactive programming. + + -- * Types + -- $intro + Event, Behavior, + + -- * IO + -- | Functions to connect events to the outside world. + Handler, newEvent, register, + currentValue, + + -- * Core Combinators + -- | Minimal set of combinators for programming with 'Event' and 'Behavior'. + module Control.Applicative, + never, filterJust, unionWith, + accumE, apply, stepper, + -- $classes + + -- * Derived Combinators + -- | Additional combinators that make programming + -- with 'Event' and 'Behavior' convenient. + -- ** Application + (<@>), (<@), + -- ** Filtering + filterE, filterApply, whenE, split, + -- ** Union + unions, concatenate, + -- ** Accumulation + -- $accumulation + accumB, mapAccum, + + -- * Additional Notes + -- $recursion + + -- * Tidings + Tidings, tidings, facts, rumors, + + -- * Internal + -- | Functions reserved for special circumstances. + -- Do not use unless you know what you're doing. + onChange, unsafeMapIO, newEventsNamed, + ) where + +import Control.Applicative +import Control.Monad (void) +import Control.Monad.IO.Class +import Data.IORef +import qualified Data.Map as Map + +import Reactive.Threepenny.Memo as Memo +import qualified Reactive.Threepenny.PulseLatch as Prim + +type Pulse = Prim.Pulse +type Latch = Prim.Latch +type Map = Map.Map + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} +{- $intro + +At its core, Functional Reactive Programming (FRP) is about two +data types 'Event' and 'Behavior' and the various ways to combine them. + +-} + +{-| @Event a@ represents a stream of events as they occur in time. +Semantically, you can think of @Event a@ as an infinite list of values +that are tagged with their corresponding time of occurence, + +> type Event a = [(Time,a)] +-} +newtype Event a = E { unE :: Memo (Pulse a) } + +{-| @Behavior a@ represents a value that varies in time. Think of it as + +> type Behavior a = Time -> a +-} +data Behavior a = B { latch :: Latch a, changes :: Event () } + +{----------------------------------------------------------------------------- + IO +------------------------------------------------------------------------------} +-- | An /event handler/ is a function that takes an +-- /event value/ and performs some computation. +type Handler a = a -> IO () + +-- | Create a new event. +-- Also returns a function that triggers an event occurrence. +newEvent :: IO (Event a, Handler a) +newEvent = do + (p, fire) <- Prim.newPulse + return (E $ fromPure p, fire) + + +-- | Create a series of events with delayed initialization. +-- +-- For each name, the initialization handler will be called +-- exactly once when the event is first "brought to life", +-- e.g. when an event handler is registered to it. +newEventsNamed :: Ord name + => Handler (name, Event a, Handler a) -- ^ Initialization procedure. + -> IO (name -> Event a) -- ^ Series of events. +newEventsNamed init = do + eventsRef <- newIORef Map.empty + return $ \name -> E $ memoize $ do + events <- readIORef eventsRef + case Map.lookup name events of + Just p -> return p + Nothing -> do + (p, fire) <- Prim.newPulse + writeIORef eventsRef $ Map.insert name p events + init (name, E $ fromPure p, fire) + return p + + +-- | Register an event 'Handler' for an 'Event'. +-- All registered handlers will be called whenever the event occurs. +-- +-- When registering an event handler, you will also be given an action +-- that unregisters this handler again. +-- +-- > do unregisterMyHandler <- register event myHandler +-- +-- FIXME: Unregistering event handlers does not work yet. +register :: Event a -> Handler a -> IO (IO ()) +register e h = do + p <- at (unE e) -- evaluate the memoized action + Prim.addHandler p h + +-- | Register an event 'Handler' for a 'Behavior'. +-- All registered handlers will be called whenever the behavior changes. +-- +-- However, note that this is only an approximation, +-- as behaviors may change continuously. +-- Consequently, handlers should be idempotent. +onChange :: Behavior a -> Handler a -> IO () +onChange (B l e) h = void $ do + -- This works because latches are updated before the handlers are being called. + register e (\_ -> h =<< Prim.readLatch l) + +-- | Read the current value of a 'Behavior'. +currentValue :: MonadIO m => Behavior a -> m a +currentValue (B l _) = liftIO $ Prim.readLatch l + + +{----------------------------------------------------------------------------- + Core Combinators +------------------------------------------------------------------------------} +instance Functor Event where + fmap f e = E $ liftMemo1 (Prim.mapP f) (unE e) + +unsafeMapIO :: (a -> IO b) -> Event a -> Event b +unsafeMapIO f e = E $ liftMemo1 (Prim.unsafeMapIOP f) (unE e) + +-- | Event that never occurs. +-- Think of it as @never = []@. +never :: Event a +never = E $ fromPure Prim.neverP + +-- | Return all event occurrences that are 'Just' values, discard the rest. +-- Think of it as +-- +-- > filterJust es = [(time,a) | (time,Just a) <- es] +filterJust e = E $ liftMemo1 Prim.filterJustP (unE e) + +-- | Merge two event streams of the same type. +-- In case of simultaneous occurrences, the event values are combined +-- with the binary function. +-- Think of it as +-- +-- > unionWith f ((timex,x):xs) ((timey,y):ys) +-- > | timex == timey = (timex,f x y) : unionWith f xs ys +-- > | timex < timey = (timex,x) : unionWith f xs ((timey,y):ys) +-- > | timex > timey = (timey,y) : unionWith f ((timex,x):xs) ys +unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a +unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2) + +-- | Apply a time-varying function to a stream of events. +-- Think of it as +-- +-- > apply bf ex = [(time, bf time x) | (time, x) <- ex] +apply :: Behavior (a -> b) -> Event a -> Event b +apply f x = E $ liftMemo1 (\p -> Prim.applyP (latch f) p) (unE x) + +infixl 4 <@>, <@ + +-- | Infix synonym for 'apply', similar to '<*>'. +(<@>) :: Behavior (a -> b) -> Event a -> Event b +(<@>) = apply + +-- | Variant of 'apply' similar to '<*' +(<@) :: Behavior a -> Event b -> Event a +b <@ e = (const <$> b) <@> e + +-- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. +-- It starts with an initial value and combines it with incoming events. +-- For example, think +-- +-- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] +-- > = stepper "x" [(time1,"xy"),(time2,"xyz")] +-- +-- Note that the value of the behavior changes \"slightly after\" +-- the events occur. This allows for recursive definitions. +accumB :: MonadIO m => a -> Event (a -> a) -> m (Behavior a) +accumB a e = liftIO $ do + (l1,p1) <- Prim.accumL a =<< at (unE e) + p2 <- Prim.mapP (const ()) p1 + return $ B l1 (E $ fromPure p2) + + +-- | Construct a time-varying function from an initial value and +-- a stream of new values. Think of it as +-- +-- > stepper x0 ex = return $ \time -> +-- > last (x0 : [x | (timex,x) <- ex, timex < time]) +-- +-- Note that the smaller-than-sign in the comparision @timex < time@ means +-- that the value of the behavior changes \"slightly after\" +-- the event occurrences. This allows for recursive definitions. +stepper :: MonadIO m => a -> Event a -> m (Behavior a) +stepper a e = accumB a (const <$> e) + +-- | The 'accumE' function accumulates a stream of events. +-- Example: +-- +-- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] +-- > = return [(time1,"xy"),(time2,"xyz")] +-- +-- Note that the output events are simultaneous with the input events, +-- there is no \"delay\" like in the case of 'accumB'. +accumE :: MonadIO m => a -> Event (a -> a) -> m (Event a) +accumE a e = liftIO $ do + p <- fmap snd . Prim.accumL a =<< at (unE e) + return $ E $ fromPure p + +instance Functor Behavior where + fmap f ~(B l e) = B (Prim.mapL f l) e + +instance Applicative Behavior where + pure a = B (Prim.pureL a) never + ~(B lf ef) <*> ~(B lx ex) = + B (Prim.applyL lf lx) (unionWith const ef ex) + +{- $classes + +/Further combinators that Haddock can't document properly./ + +> instance Applicative Behavior + +'Behavior' is an applicative functor. In particular, we have the following functions. + +> pure :: a -> Behavior a + +The constant time-varying value. Think of it as @pure x = \\time -> x@. + +> (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b + +Combine behaviors in applicative style. +Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. + +-} + +{- $recursion + +Recursion in the 'IO' monad is possible, but somewhat limited. +The main rule is that the sequence of IO actions must be known +in advance, only the values may be recursive. + +Good: + +> mdo +> let e2 = apply (const <$> b) e1 -- applying a behavior is not an IO action +> b <- accumB $ (+1) <$ e2 + +Bad: + +> mdo +> b <- accumB $ (+1) <$ e2 -- actions executed here could depend ... +> let e2 = apply (const <$> b) e1 -- ... on this value + +-} + +{----------------------------------------------------------------------------- + Derived Combinators +------------------------------------------------------------------------------} +-- | Return all event occurrences that fulfill the predicate, discard the rest. +filterE :: (a -> Bool) -> Event a -> Event a +filterE p = filterJust . fmap (\a -> if p a then Just a else Nothing) + +-- | Return all event occurrences that fulfill the time-varying predicate, +-- discard the rest. Generalization of 'filterE'. +filterApply :: Behavior (a -> Bool) -> Event a -> Event a +filterApply bp = fmap snd . filterE fst . apply ((\p a -> (p a,a)) <$> bp) + +-- | Return event occurrences only when the behavior is 'True'. +-- Variant of 'filterApply'. +whenE :: Behavior Bool -> Event a -> Event a +whenE bf = filterApply (const <$> bf) + +-- | Split event occurrences according to a tag. +-- The 'Left' values go into the left component while the 'Right' values +-- go into the right component of the result. +split :: Event (Either a b) -> (Event a, Event b) +split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) + where + fromLeft (Left a) = Just a + fromLeft (Right b) = Nothing + fromRight (Left a) = Nothing + fromRight (Right b) = Just b + +-- | Collect simultaneous event occurrences in a list. +unions :: [Event a] -> Event [a] +unions = foldr (unionWith (++)) never . map (fmap (:[])) + +-- | Apply a list of functions in succession. +-- Useful in conjunction with 'unions'. +-- +-- > concatenate [f,g,h] = f . g . h +concatenate :: [a -> a] -> (a -> a) +concatenate = foldr (.) id + +{- $accumulation + +Note: All accumulation functions are strict in the accumulated value! +acc -> (x,acc) is the order used by 'unfoldr' and 'State'. + +-} + +-- | Efficient combination of 'accumE' and 'accumB'. +mapAccum :: MonadIO m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc) +mapAccum acc ef = do + e <- accumE (undefined,acc) ((. snd) <$> ef) + b <- stepper acc (snd <$> e) + return (fst <$> e, b) + + +{----------------------------------------------------------------------------- + Tidings + + Data type for combining user events. + See + for more information. +------------------------------------------------------------------------------} +-- | Data type representing a behavior ('facts') +-- and suggestions to change it ('rumors'). +data Tidings a = T { facts :: Behavior a, rumors :: Event a } + +-- | Smart constructor. Combine facts and rumors into 'Tidings'. +tidings :: Behavior a -> Event a -> Tidings a +tidings b e = T b e + +instance Functor Tidings where + fmap f (T b e) = T (fmap f b) (fmap f e) + +-- | The applicative instance combines 'rumors' +-- and uses 'facts' when some of the 'rumors' are not available. +instance Applicative Tidings where + pure x = T (pure x) never + f <*> x = uncurry ($) <$> pair f x + +pair :: Tidings a -> Tidings b -> Tidings (a,b) +pair (T bx ex) (T by ey) = T b e + where + b = (,) <$> bx <*> by + x = flip (,) <$> by <@> ex + y = (,) <$> bx <@> ey + e = unionWith (\(x,_) (_,y) -> (x,y)) x y + + +{----------------------------------------------------------------------------- + Test +------------------------------------------------------------------------------} +test :: IO (Int -> IO ()) +test = do + (e1,fire) <- newEvent + e2 <- accumE 0 $ (+) <$> e1 + _ <- register e2 print + + return fire + +test_recursion1 :: IO (IO ()) +test_recursion1 = mdo + (e1, fire) <- newEvent + let e2 :: Event Int + e2 = apply (const <$> b) e1 + b <- accumB 0 $ (+1) <$ e2 + _ <- register e2 print + + return $ fire () + + diff --git a/src/Reactive/Threepenny/Memo.hs b/src/Reactive/Threepenny/Memo.hs --- a/src/Reactive/Threepenny/Memo.hs +++ b/src/Reactive/Threepenny/Memo.hs @@ -1,43 +1,43 @@ -{-# LANGUAGE RecursiveDo #-} -module Reactive.Threepenny.Memo ( - Memo, fromPure, memoize, at, liftMemo1, liftMemo2, - ) where - -import Control.Monad -import Data.Functor -import Data.IORef -import System.IO.Unsafe - -{----------------------------------------------------------------------------- - Memoize time-varying values / computations -------------------------------------------------------------------------------} -data Memo a - = Const a - | Memoized (IORef (MemoD a)) - -type MemoD a = Either (IO a) a - -fromPure = Const - -at :: Memo a -> IO a -at (Const a) = return a -at (Memoized r) = do - memo <- readIORef r - case memo of - Right a -> return a - Left ma -> mdo - writeIORef r $ Right a - a <- ma -- allow some recursion - return a - -memoize :: IO a -> Memo a -memoize m = unsafePerformIO $ Memoized <$> newIORef (Left m) - -liftMemo1 :: (a -> IO b) -> Memo a -> Memo b -liftMemo1 f ma = memoize $ f =<< at ma - -liftMemo2 :: (a -> b -> IO c) -> Memo a -> Memo b -> Memo c -liftMemo2 f ma mb = memoize $ do - a <- at ma - b <- at mb - f a b +{-# LANGUAGE RecursiveDo #-} +module Reactive.Threepenny.Memo ( + Memo, fromPure, memoize, at, liftMemo1, liftMemo2, + ) where + +import Control.Monad +import Data.Functor +import Data.IORef +import System.IO.Unsafe + +{----------------------------------------------------------------------------- + Memoize time-varying values / computations +------------------------------------------------------------------------------} +data Memo a + = Const a + | Memoized (IORef (MemoD a)) + +type MemoD a = Either (IO a) a + +fromPure = Const + +at :: Memo a -> IO a +at (Const a) = return a +at (Memoized r) = do + memo <- readIORef r + case memo of + Right a -> return a + Left ma -> mdo + writeIORef r $ Right a + a <- ma -- allow some recursion + return a + +memoize :: IO a -> Memo a +memoize m = unsafePerformIO $ Memoized <$> newIORef (Left m) + +liftMemo1 :: (a -> IO b) -> Memo a -> Memo b +liftMemo1 f ma = memoize $ f =<< at ma + +liftMemo2 :: (a -> b -> IO c) -> Memo a -> Memo b -> Memo c +liftMemo2 f ma mb = memoize $ do + a <- at ma + b <- at mb + f a b diff --git a/src/Reactive/Threepenny/Monads.hs b/src/Reactive/Threepenny/Monads.hs --- a/src/Reactive/Threepenny/Monads.hs +++ b/src/Reactive/Threepenny/Monads.hs @@ -1,12 +1,12 @@ -module Reactive.Threepenny.Monads where - -import Control.Monad.Trans.RWS.Lazy -import Reactive.Threepenny.Types - -{----------------------------------------------------------------------------- - EvalP - evaluate pulses -------------------------------------------------------------------------------} -runEvalP :: Values -> EvalP a -> IO (a, Values) -runEvalP pulses m = do - (a, s, _) <- runRWST m () pulses - return (a, s) +module Reactive.Threepenny.Monads where + +import Control.Monad.Trans.RWS.Lazy +import Reactive.Threepenny.Types + +{----------------------------------------------------------------------------- + EvalP - evaluate pulses +------------------------------------------------------------------------------} +runEvalP :: Values -> EvalP a -> IO (a, Values) +runEvalP pulses m = do + (a, s, _) <- runRWST m () pulses + return (a, s) diff --git a/src/Reactive/Threepenny/PulseLatch.hs b/src/Reactive/Threepenny/PulseLatch.hs --- a/src/Reactive/Threepenny/PulseLatch.hs +++ b/src/Reactive/Threepenny/PulseLatch.hs @@ -1,205 +1,205 @@ -{-# LANGUAGE RecordWildCards, RecursiveDo #-} -module Reactive.Threepenny.PulseLatch ( - Pulse, newPulse, addHandler, - neverP, mapP, filterJustP, unionWithP, unsafeMapIOP, - - Latch, - pureL, mapL, applyL, accumL, applyP, - readLatch, - ) where - - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS as Monad - -import Data.IORef -import Data.Monoid (Endo(..)) - -import Data.Hashable -import qualified Data.HashMap.Strict as Map -import qualified Data.Vault.Strict as Vault -import Data.Unique.Really - -import Reactive.Threepenny.Monads -import Reactive.Threepenny.Types - -type Map = Map.HashMap - -{----------------------------------------------------------------------------- - Pulse -------------------------------------------------------------------------------} --- Turn evaluation action into pulse that caches the value. -cacheEval :: EvalP (Maybe a) -> Build (Pulse a) -cacheEval e = do - key <- Vault.newKey - return $ Pulse - { addHandlerP = \_ -> return (return ()) - , evalP = do - vault <- Monad.get - case Vault.lookup key vault of - Just a -> return a - Nothing -> do - a <- e - Monad.put $ Vault.insert key a vault - return a - } - --- Add a dependency to a pulse, for the sake of keeping track of dependencies. -dependOn :: Pulse a -> Pulse b -> Pulse a -dependOn p q = p { addHandlerP = \h -> (>>) <$> addHandlerP p h <*> addHandlerP q h } - --- Execute an action when the pulse occurs -whenPulse :: Pulse a -> (a -> IO ()) -> Handler -whenPulse p f = do - ma <- evalP p - case ma of - Just a -> return (f a) - Nothing -> return $ return () - -{----------------------------------------------------------------------------- - Interface to the outside world. -------------------------------------------------------------------------------} --- | Create a new pulse and a function to trigger it. -newPulse :: Build (Pulse a, a -> IO ()) -newPulse = do - key <- Vault.newKey - handlersRef <- newIORef Map.empty -- map of handlers - - let - -- add handler to map - addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ()) - addHandlerP (uid,m) = do - modifyIORef' handlersRef (Map.insert uid m) - return $ modifyIORef' handlersRef (Map.delete uid) - - -- evaluate all handlers attached to this input pulse - fireP a = do - let pulses = Vault.insert key (Just a) $ Vault.empty - handlers <- readIORef handlersRef - (ms, _) <- runEvalP pulses $ sequence $ - [m | ((_,DoLatch),m) <- Map.toList handlers] - ++ [m | ((_,DoIO ),m) <- Map.toList handlers] - sequence_ ms - - evalP = join . Vault.lookup key <$> Monad.get - - return (Pulse {..}, fireP) - --- | Register a handler to be executed whenever a pulse occurs. -addHandler :: Pulse a -> (a -> IO ()) -> Build (IO ()) -addHandler p f = do - uid <- newUnique - addHandlerP p ((uid, DoIO), whenPulse p f) - --- | Read the value of a 'Latch' at a particular moment in Build. -readLatch :: Latch a -> Build a -readLatch = readL - -{----------------------------------------------------------------------------- - Pulse and Latch - Public API -------------------------------------------------------------------------------} --- | Create a new pulse that never occurs. -neverP :: Pulse a -neverP = Pulse - { addHandlerP = const $ return (return ()) - , evalP = return Nothing - } - --- | Map a function over pulses. -mapP :: (a -> b) -> Pulse a -> Build (Pulse b) -mapP f p = (`dependOn` p) <$> cacheEval (return . fmap f =<< evalP p) - --- | Map an IO function over pulses. Is only executed once. -unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b) -unsafeMapIOP f p = (`dependOn` p) <$> cacheEval (traverse . fmap f =<< evalP p) - where - traverse :: Maybe (IO a) -> EvalP (Maybe a) - traverse Nothing = return Nothing - traverse (Just m) = Just <$> lift m - --- | Filter occurrences. Only keep those of the form 'Just'. -filterJustP :: Pulse (Maybe a) -> Build (Pulse a) -filterJustP p = (`dependOn` p) <$> cacheEval (return . join =<< evalP p) - --- | Pulse that occurs when either of the pulses occur. --- Combines values with the indicated function when both occur. -unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a) -unionWithP f p q = (`dependOn` q) . (`dependOn` p) <$> cacheEval eval - where - eval = do - x <- evalP p - y <- evalP q - return $ case (x,y) of - (Nothing, Nothing) -> Nothing - (Just a , Nothing) -> Just a - (Nothing, Just a ) -> Just a - (Just a1, Just a2) -> Just $ f a1 a2 - --- | Apply the current latch value whenever the pulse occurs. -applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b) -applyP l p = (`dependOn` p) <$> cacheEval eval - where - eval = do - f <- lift $ readL l - a <- evalP p - return $ f <$> a - --- | Accumulate values in a latch. -accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) -accumL a p1 = do - -- IORef to hold the current latch value - latch <- newIORef a - let l1 = Latch { readL = readIORef latch } - - -- calculate new pulse from old value - let l2 = mapL (flip ($)) l1 - p2 <- applyP l2 p1 - - -- register handler to update latch - uid <- newUnique - let handler = whenPulse p2 $ (writeIORef latch $!) - void $ addHandlerP p2 ((uid, DoLatch), handler) - - return (l1,p2) - --- | Latch whose value stays constant. -pureL :: a -> Latch a -pureL a = Latch { readL = return a } - --- | Map a function over latches. --- --- Evaluated only when needed, result is not cached. -mapL :: (a -> b) -> Latch a -> Latch b -mapL f l = Latch { readL = f <$> readL l } - --- | Apply two current latch values --- --- Evaluated only when needed, result is not cached. -applyL :: Latch (a -> b) -> Latch a -> Latch b -applyL l1 l2 = Latch { readL = readL l1 <*> readL l2 } - -{----------------------------------------------------------------------------- - Test -------------------------------------------------------------------------------} -test :: IO (Int -> IO ()) -test = do - (p1, fire) <- newPulse - p2 <- mapP (+) p1 - (l1,_) <- accumL 0 p2 - let l2 = mapL const l1 - p3 <- applyP l2 p1 - void $ addHandler p3 print - return fire - -test_recursion1 :: IO (IO ()) -test_recursion1 = mdo - (p1, fire) <- newPulse - p2 <- applyP l2 p1 - p3 <- mapP (const (+1)) p2 - ~(l1,_) <- accumL (0::Int) p3 - let l2 = mapL const l1 - void $ addHandler p2 print - return $ fire () +{-# LANGUAGE RecordWildCards, RecursiveDo #-} +module Reactive.Threepenny.PulseLatch ( + Pulse, newPulse, addHandler, + neverP, mapP, filterJustP, unionWithP, unsafeMapIOP, + + Latch, + pureL, mapL, applyL, accumL, applyP, + readLatch, + ) where + + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.RWS as Monad + +import Data.IORef +import Data.Monoid (Endo(..)) + +import Data.Hashable +import qualified Data.HashMap.Strict as Map +import qualified Data.Vault.Strict as Vault +import Data.Unique.Really + +import Reactive.Threepenny.Monads +import Reactive.Threepenny.Types + +type Map = Map.HashMap + +{----------------------------------------------------------------------------- + Pulse +------------------------------------------------------------------------------} +-- Turn evaluation action into pulse that caches the value. +cacheEval :: EvalP (Maybe a) -> Build (Pulse a) +cacheEval e = do + key <- Vault.newKey + return $ Pulse + { addHandlerP = \_ -> return (return ()) + , evalP = do + vault <- Monad.get + case Vault.lookup key vault of + Just a -> return a + Nothing -> do + a <- e + Monad.put $ Vault.insert key a vault + return a + } + +-- Add a dependency to a pulse, for the sake of keeping track of dependencies. +dependOn :: Pulse a -> Pulse b -> Pulse a +dependOn p q = p { addHandlerP = \h -> (>>) <$> addHandlerP p h <*> addHandlerP q h } + +-- Execute an action when the pulse occurs +whenPulse :: Pulse a -> (a -> IO ()) -> Handler +whenPulse p f = do + ma <- evalP p + case ma of + Just a -> return (f a) + Nothing -> return $ return () + +{----------------------------------------------------------------------------- + Interface to the outside world. +------------------------------------------------------------------------------} +-- | Create a new pulse and a function to trigger it. +newPulse :: Build (Pulse a, a -> IO ()) +newPulse = do + key <- Vault.newKey + handlersRef <- newIORef Map.empty -- map of handlers + + let + -- add handler to map + addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ()) + addHandlerP (uid,m) = do + modifyIORef' handlersRef (Map.insert uid m) + return $ modifyIORef' handlersRef (Map.delete uid) + + -- evaluate all handlers attached to this input pulse + fireP a = do + let pulses = Vault.insert key (Just a) $ Vault.empty + handlers <- readIORef handlersRef + (ms, _) <- runEvalP pulses $ sequence $ + [m | ((_,DoLatch),m) <- Map.toList handlers] + ++ [m | ((_,DoIO ),m) <- Map.toList handlers] + sequence_ ms + + evalP = join . Vault.lookup key <$> Monad.get + + return (Pulse {..}, fireP) + +-- | Register a handler to be executed whenever a pulse occurs. +addHandler :: Pulse a -> (a -> IO ()) -> Build (IO ()) +addHandler p f = do + uid <- newUnique + addHandlerP p ((uid, DoIO), whenPulse p f) + +-- | Read the value of a 'Latch' at a particular moment in Build. +readLatch :: Latch a -> Build a +readLatch = readL + +{----------------------------------------------------------------------------- + Pulse and Latch + Public API +------------------------------------------------------------------------------} +-- | Create a new pulse that never occurs. +neverP :: Pulse a +neverP = Pulse + { addHandlerP = const $ return (return ()) + , evalP = return Nothing + } + +-- | Map a function over pulses. +mapP :: (a -> b) -> Pulse a -> Build (Pulse b) +mapP f p = (`dependOn` p) <$> cacheEval (return . fmap f =<< evalP p) + +-- | Map an IO function over pulses. Is only executed once. +unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b) +unsafeMapIOP f p = (`dependOn` p) <$> cacheEval (traverse . fmap f =<< evalP p) + where + traverse :: Maybe (IO a) -> EvalP (Maybe a) + traverse Nothing = return Nothing + traverse (Just m) = Just <$> lift m + +-- | Filter occurrences. Only keep those of the form 'Just'. +filterJustP :: Pulse (Maybe a) -> Build (Pulse a) +filterJustP p = (`dependOn` p) <$> cacheEval (return . join =<< evalP p) + +-- | Pulse that occurs when either of the pulses occur. +-- Combines values with the indicated function when both occur. +unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a) +unionWithP f p q = (`dependOn` q) . (`dependOn` p) <$> cacheEval eval + where + eval = do + x <- evalP p + y <- evalP q + return $ case (x,y) of + (Nothing, Nothing) -> Nothing + (Just a , Nothing) -> Just a + (Nothing, Just a ) -> Just a + (Just a1, Just a2) -> Just $ f a1 a2 + +-- | Apply the current latch value whenever the pulse occurs. +applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b) +applyP l p = (`dependOn` p) <$> cacheEval eval + where + eval = do + f <- lift $ readL l + a <- evalP p + return $ f <$> a + +-- | Accumulate values in a latch. +accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) +accumL a p1 = do + -- IORef to hold the current latch value + latch <- newIORef a + let l1 = Latch { readL = readIORef latch } + + -- calculate new pulse from old value + let l2 = mapL (flip ($)) l1 + p2 <- applyP l2 p1 + + -- register handler to update latch + uid <- newUnique + let handler = whenPulse p2 $ (writeIORef latch $!) + void $ addHandlerP p2 ((uid, DoLatch), handler) + + return (l1,p2) + +-- | Latch whose value stays constant. +pureL :: a -> Latch a +pureL a = Latch { readL = return a } + +-- | Map a function over latches. +-- +-- Evaluated only when needed, result is not cached. +mapL :: (a -> b) -> Latch a -> Latch b +mapL f l = Latch { readL = f <$> readL l } + +-- | Apply two current latch values +-- +-- Evaluated only when needed, result is not cached. +applyL :: Latch (a -> b) -> Latch a -> Latch b +applyL l1 l2 = Latch { readL = readL l1 <*> readL l2 } + +{----------------------------------------------------------------------------- + Test +------------------------------------------------------------------------------} +test :: IO (Int -> IO ()) +test = do + (p1, fire) <- newPulse + p2 <- mapP (+) p1 + (l1,_) <- accumL 0 p2 + let l2 = mapL const l1 + p3 <- applyP l2 p1 + void $ addHandler p3 print + return fire + +test_recursion1 :: IO (IO ()) +test_recursion1 = mdo + (p1, fire) <- newPulse + p2 <- applyP l2 p1 + p3 <- mapP (const (+1)) p2 + ~(l1,_) <- accumL (0::Int) p3 + let l2 = mapL const l1 + void $ addHandler p2 print + return $ fire () diff --git a/src/Reactive/Threepenny/Types.hs b/src/Reactive/Threepenny/Types.hs --- a/src/Reactive/Threepenny/Types.hs +++ b/src/Reactive/Threepenny/Types.hs @@ -1,39 +1,39 @@ -module Reactive.Threepenny.Types where - -import Control.Monad.Trans.RWS.Lazy -import Data.Functor.Identity () - -import Data.Hashable -import qualified Data.Vault.Strict as Vault.Strict -import Data.Unique.Really - -{----------------------------------------------------------------------------- - Pulse and Latch -------------------------------------------------------------------------------} -type Values = Vault.Strict.Vault - -type Handler = EvalP (IO ()) -data Priority = DoLatch | DoIO deriving (Eq,Show,Ord,Enum) - -data Pulse a = Pulse - { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ()) - , evalP :: EvalP (Maybe a) - } - -instance Hashable Priority where hashWithSalt _ = fromEnum - -data Latch a = Latch { readL :: EvalL a } - -{----------------------------------------------------------------------------- - Monads -------------------------------------------------------------------------------} --- | The 'EvalP' monad is used to evaluate pulses. -type EvalP = RWST () () Values BuildIO - -- state: current pulse values - --- | The 'EvalL' monad is used to evaluate latches. -type EvalL = IO - --- | The 'Build' monad is used to add pulses and latches to the graph. -type Build = IO -type BuildIO = Build +module Reactive.Threepenny.Types where + +import Control.Monad.Trans.RWS.Lazy +import Data.Functor.Identity () + +import Data.Hashable +import qualified Data.Vault.Strict as Vault.Strict +import Data.Unique.Really + +{----------------------------------------------------------------------------- + Pulse and Latch +------------------------------------------------------------------------------} +type Values = Vault.Strict.Vault + +type Handler = EvalP (IO ()) +data Priority = DoLatch | DoIO deriving (Eq,Show,Ord,Enum) + +data Pulse a = Pulse + { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ()) + , evalP :: EvalP (Maybe a) + } + +instance Hashable Priority where hashWithSalt _ = fromEnum + +data Latch a = Latch { readL :: EvalL a } + +{----------------------------------------------------------------------------- + Monads +------------------------------------------------------------------------------} +-- | The 'EvalP' monad is used to evaluate pulses. +type EvalP = RWST () () Values BuildIO + -- state: current pulse values + +-- | The 'EvalL' monad is used to evaluate latches. +type EvalL = IO + +-- | The 'Build' monad is used to add pulses and latches to the graph. +type Build = IO +type BuildIO = Build diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal --- a/threepenny-gui.cabal +++ b/threepenny-gui.cabal @@ -1,240 +1,240 @@ -Name: threepenny-gui -Version: 0.8.2.1 -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. - . - It's very easy to install because everyone has a web browser installed. - . - 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. - You can freely manipulate the HTML DOM and handle JavaScript events - from your Haskell code. - . - Stability forecast: This is an experimental release! Send me your feedback! - Significant API changes are likely in future versions. - . - NOTE: This library contains examples, but they are not built by default. - To build and install the example, use the @buildExamples@ flag like this - . - @cabal install threepenny-gui -fbuildExamples@ - -License: BSD3 -License-file: LICENSE -Author: Heinrich Apfelmus -Maintainer: Heinrich Apfelmus -Homepage: http://wiki.haskell.org/Threepenny-gui -bug-reports: https://github.com/HeinrichApfelmus/threepenny-gui/issues -Category: Web, GUI -Build-type: Simple -Cabal-version: >=1.8 - -Extra-Source-Files: CHANGELOG.md - ,README.md - ,samples/README.md - ,js/*.html - ,js/*.css - ,js/*.js - ,js/lib/*.js - -Data-dir: . -Data-files: samples/static/css/*.css - ,samples/static/css/*.png - ,samples/static/*.html - ,samples/static/*.png - ,samples/static/*.wav - - -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 - non-deterministic, for example garbage collection - and concurrency. - 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 - location: git://github.com/HeinrichApfelmus/threepenny-gui.git - - -Library - hs-source-dirs: src - exposed-modules: - Foreign.JavaScript - ,Foreign.RemotePtr - ,Graphics.UI.Threepenny - ,Graphics.UI.Threepenny.Attributes - ,Graphics.UI.Threepenny.Canvas - ,Graphics.UI.Threepenny.Core - ,Graphics.UI.Threepenny.DragNDrop - ,Graphics.UI.Threepenny.Elements - ,Graphics.UI.Threepenny.Events - ,Graphics.UI.Threepenny.JQuery - ,Graphics.UI.Threepenny.SVG - ,Graphics.UI.Threepenny.SVG.Attributes - ,Graphics.UI.Threepenny.SVG.Elements - ,Graphics.UI.Threepenny.Timer - ,Graphics.UI.Threepenny.Widgets - ,Reactive.Threepenny - other-modules: - Foreign.JavaScript.CallBuffer - ,Foreign.JavaScript.EventLoop - ,Foreign.JavaScript.Include - ,Foreign.JavaScript.Marshal - ,Foreign.JavaScript.Resources - ,Foreign.JavaScript.Server - ,Foreign.JavaScript.Types - ,Graphics.UI.Threepenny.Internal - ,Reactive.Threepenny.Memo - ,Reactive.Threepenny.Monads - ,Reactive.Threepenny.PulseLatch - ,Reactive.Threepenny.Types - ,Paths_threepenny_gui - extensions: CPP - cpp-options: -DCABAL - if flag(rebug) - cpp-options: -DREBUG - ghc-options: -O2 - build-depends: base >= 4.6 && < 4.11 - ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.3) - ,async >= 2.0 && < 2.3 - ,bytestring >= 0.9.2 && < 0.11 - ,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 - ,file-embed >= 0.0.10 && < 0.1 - ,hashable >= 1.1.0 && < 1.3 - ,safe == 0.3.* - ,snap-server >= 0.9.0 && < 1.1 - ,snap-core >= 0.9.0 && < 1.1 - ,stm >= 2.2 && < 2.5 - ,template-haskell >= 2.7.0 && < 2.13 - ,text >= 0.11 && < 1.3 - ,transformers >= 0.3.0 && < 0.6 - ,unordered-containers == 0.2.* - ,websockets >= 0.8 && < 0.13 - ,websockets-snap >= 0.8 && < 0.11 - ,vault == 0.3.* - ,vector >= 0.10 && < 0.13 - if flag(network-uri) - build-depends: network-uri >= 2.6 && < 2.7 - else - build-depends: network >= 2.3.0 && < 2.6 - -Executable threepenny-examples-bartab - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - else - buildable: False - main-is: BarTab.hs - hs-source-dirs: samples - -Executable threepenny-examples-buttons - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - ,filepath - else - buildable: False - main-is: Buttons.hs - other-modules: Paths_threepenny_gui, Paths - hs-source-dirs: samples - -Executable threepenny-examples-canvas - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,filepath - ,threepenny-gui - else - buildable: False - main-is: Canvas.hs - other-modules: Paths - hs-source-dirs: samples - -Executable threepenny-examples-chat - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - ,transformers - ,filepath - ,time - else - buildable: False - main-is: Chat.hs - other-modules: Paths_threepenny_gui, Paths, Data.List.Extra - hs-source-dirs: samples - -Executable threepenny-examples-crud - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,containers - ,threepenny-gui - else - buildable: False - main-is: CRUD.hs - hs-source-dirs: samples - -Executable threepenny-examples-currencyconverter - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - ,safe - else - buildable: False - main-is: CurrencyConverter.hs - hs-source-dirs: samples - -Executable threepenny-examples-dragndropexample - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - ,filepath - else - buildable: False - main-is: DragNDropExample.hs - other-modules: Paths_threepenny_gui, Paths - hs-source-dirs: samples - -Executable threepenny-examples-drummachine - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - ,filepath - else - buildable: False - main-is: DrumMachine.hs - other-modules: Paths_threepenny_gui, Paths - hs-source-dirs: samples - -Executable threepenny-examples-svg - if flag(buildExamples) - cpp-options: -DCABAL - build-depends: base >= 4 && < 5 - ,threepenny-gui - else - buildable: False - main-is: Svg.hs - hs-source-dirs: samples +Name: threepenny-gui +Version: 0.8.2.2 +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. + . + It's very easy to install because everyone has a web browser installed. + . + 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. + You can freely manipulate the HTML DOM and handle JavaScript events + from your Haskell code. + . + Stability forecast: This is an experimental release! Send me your feedback! + Significant API changes are likely in future versions. + . + NOTE: This library contains examples, but they are not built by default. + To build and install the example, use the @buildExamples@ flag like this + . + @cabal install threepenny-gui -fbuildExamples@ + +License: BSD3 +License-file: LICENSE +Author: Heinrich Apfelmus +Maintainer: Heinrich Apfelmus +Homepage: http://wiki.haskell.org/Threepenny-gui +bug-reports: https://github.com/HeinrichApfelmus/threepenny-gui/issues +Category: Web, GUI +Build-type: Simple +Cabal-version: >=1.8 + +Extra-Source-Files: CHANGELOG.md + ,README.md + ,samples/README.md + ,js/*.html + ,js/*.css + ,js/*.js + ,js/lib/*.js + +Data-dir: . +Data-files: samples/static/css/*.css + ,samples/static/css/*.png + ,samples/static/*.html + ,samples/static/*.png + ,samples/static/*.wav + + +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 + non-deterministic, for example garbage collection + and concurrency. + 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 + location: git://github.com/HeinrichApfelmus/threepenny-gui.git + + +Library + hs-source-dirs: src + exposed-modules: + Foreign.JavaScript + ,Foreign.RemotePtr + ,Graphics.UI.Threepenny + ,Graphics.UI.Threepenny.Attributes + ,Graphics.UI.Threepenny.Canvas + ,Graphics.UI.Threepenny.Core + ,Graphics.UI.Threepenny.DragNDrop + ,Graphics.UI.Threepenny.Elements + ,Graphics.UI.Threepenny.Events + ,Graphics.UI.Threepenny.JQuery + ,Graphics.UI.Threepenny.SVG + ,Graphics.UI.Threepenny.SVG.Attributes + ,Graphics.UI.Threepenny.SVG.Elements + ,Graphics.UI.Threepenny.Timer + ,Graphics.UI.Threepenny.Widgets + ,Reactive.Threepenny + other-modules: + Foreign.JavaScript.CallBuffer + ,Foreign.JavaScript.EventLoop + ,Foreign.JavaScript.Include + ,Foreign.JavaScript.Marshal + ,Foreign.JavaScript.Resources + ,Foreign.JavaScript.Server + ,Foreign.JavaScript.Types + ,Graphics.UI.Threepenny.Internal + ,Reactive.Threepenny.Memo + ,Reactive.Threepenny.Monads + ,Reactive.Threepenny.PulseLatch + ,Reactive.Threepenny.Types + ,Paths_threepenny_gui + extensions: CPP + cpp-options: -DCABAL + if flag(rebug) + cpp-options: -DREBUG + ghc-options: -O2 + build-depends: base >= 4.6 && < 4.11 + ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.3) + ,async >= 2.0 && < 2.3 + ,bytestring >= 0.9.2 && < 0.11 + ,containers >= 0.4.2 && < 0.6 + ,data-default >= 0.5.0 && < 0.8 + ,deepseq >= 1.3.0 && < 1.5 + ,exceptions >= 0.6 && < 0.10 + ,filepath >= 1.3.0 && < 1.5.0 + ,file-embed >= 0.0.10 && < 0.1 + ,hashable >= 1.1.0 && < 1.3 + ,safe == 0.3.* + ,snap-server >= 0.9.0 && < 1.1 + ,snap-core >= 0.9.0 && < 1.1 + ,stm >= 2.2 && < 2.5 + ,template-haskell >= 2.7.0 && < 2.13 + ,text >= 0.11 && < 1.3 + ,transformers >= 0.3.0 && < 0.6 + ,unordered-containers == 0.2.* + ,websockets >= 0.8 && < 0.13 + ,websockets-snap >= 0.8 && < 0.11 + ,vault == 0.3.* + ,vector >= 0.10 && < 0.13 + if flag(network-uri) + build-depends: network-uri >= 2.6 && < 2.7 + else + build-depends: network >= 2.3.0 && < 2.6 + +Executable threepenny-examples-bartab + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + else + buildable: False + main-is: BarTab.hs + hs-source-dirs: samples + +Executable threepenny-examples-buttons + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + ,filepath + else + buildable: False + main-is: Buttons.hs + other-modules: Paths_threepenny_gui, Paths + hs-source-dirs: samples + +Executable threepenny-examples-canvas + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,filepath + ,threepenny-gui + else + buildable: False + main-is: Canvas.hs + other-modules: Paths + hs-source-dirs: samples + +Executable threepenny-examples-chat + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + ,transformers + ,filepath + ,time + else + buildable: False + main-is: Chat.hs + other-modules: Paths_threepenny_gui, Paths, Data.List.Extra + hs-source-dirs: samples + +Executable threepenny-examples-crud + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,containers + ,threepenny-gui + else + buildable: False + main-is: CRUD.hs + hs-source-dirs: samples + +Executable threepenny-examples-currencyconverter + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + ,safe + else + buildable: False + main-is: CurrencyConverter.hs + hs-source-dirs: samples + +Executable threepenny-examples-dragndropexample + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + ,filepath + else + buildable: False + main-is: DragNDropExample.hs + other-modules: Paths_threepenny_gui, Paths + hs-source-dirs: samples + +Executable threepenny-examples-drummachine + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + ,filepath + else + buildable: False + main-is: DrumMachine.hs + other-modules: Paths_threepenny_gui, Paths + hs-source-dirs: samples + +Executable threepenny-examples-svg + if flag(buildExamples) + cpp-options: -DCABAL + build-depends: base >= 4 && < 5 + ,threepenny-gui + else + buildable: False + main-is: Svg.hs + hs-source-dirs: samples