react-flux 0.9.4 → 1.0.0
raw patch · 35 files changed
+1408/−194 lines, 35 filesdep +template-haskelldep +unordered-containersdep ~basedep ~textdep ~timenew-component:exe:test-client-13new-component:exe:test-client-14new-component:exe:todo-node
Dependencies added: template-haskell, unordered-containers
Dependency ranges changed: base, text, time
Files
- ChangeLog.md +28/−0
- README.md +9/−7
- example/README.md +16/−3
- example/todo/Makefile +2/−2
- example/todo/NodeMain.hs +6/−0
- example/todo/run-in-node.js +2/−0
- example/todo/todo-dev.html +2/−1
- example/todo/todo.html +2/−1
- jsbits/callback.js +9/−0
- jsbits/views.js +11/−0
- react-flux.cabal +51/−9
- src/React/Flux.hs +56/−8
- src/React/Flux/Addons/Bootstrap.hs +9/−2
- src/React/Flux/Addons/Intl.hs +582/−0
- src/React/Flux/Addons/React.hs +7/−30
- src/React/Flux/DOM.hs +2/−0
- src/React/Flux/Internal.hs +56/−29
- src/React/Flux/PropertiesAndEvents.hs +115/−58
- src/React/Flux/Store.hs +1/−1
- src/React/Flux/Views.hs +9/−7
- test/client/TestClient.hs +118/−15
- test/client/TestClient13.hs +9/−0
- test/client/TestClient14.hs +93/−0
- test/client/msgs/android.xml +10/−0
- test/client/msgs/jsonmsgs.json +1/−0
- test/client/msgs/jsonnodescr.json +1/−0
- test/client/test-client.html +0/−10
- test/client/test-client13.html +12/−0
- test/client/test-client14.html +13/−0
- test/spec/Main.hs +10/−0
- test/spec/Spec.hs +1/−1
- test/spec/TestClientSpec.hs +157/−4
- test/spec/TodoSpec.hs +3/−3
- test/spec/react-flux-spec.cabal +4/−2
- test/spec/stack.yaml +1/−1
ChangeLog.md view
@@ -1,3 +1,31 @@+# 1.0.0++* Bindings to react-intl (http://formatjs.io/react/) for i18n support. This is useful even if your app is+ a single language, as it allows easy number, date, relative time, and message formatting like pluralization.+ It also supports multiple locales and translations of messages.++* The type of `callback` has extended to allow arbitrary function properties to be+ passed to foreign classes. The old `callback` accepted callbacks of type `Aeson.Value -> handler`+ while the new callback allows functions of any number of arguments, as long as each argument implements+ `FromJSRef`. Since `Aeson.Value` implements `FromJSRef`, any existing calls to `callback` should still work.+ This change also caused some changes to types in `React.Flux.Internal`.++* Add a function `nestedProperty` to `React.Flux.PropertiesAndEvents` to create nested properties.++* Support for React 0.14+ * React 0.13 and 0.14 are both supported from the same Haskell code, the differences are handled internally.+ * If you are using React 0.14, you will have to include `react-dom.min.js` and make sure the+ `ReactDOM` variable is protected by closure similar to how `React` must be protected.+ * `initializeTouchEvents` has been removed from React 0.14, so you can remove the call from your app.+ * The SVG `image_` tag is now supported by `React.Flux.DOM`.+ * The new media events on images and videos don't have direct Haskell equivalents, instead the handlers can be+ created by the new `on` function in `React.Flux.PropertiesAndEvents`.+ * The CSS transitions in `React.Flux.Addons.React` were made simpler by just passing the raw+ properties. There were several changes to the possible properties in React 0.14 and covering them all+ from Haskell is not worth it when the properties can easily be created directly.++* `reactRenderToString` was added to allow executing a react-flux application using node.+ # 0.9.4 * Fix to build with latest ghcjs-base (requires at least aaa4d59117f37d1b9c60a154a9128b3bcc6301cd)
README.md view
@@ -46,23 +46,25 @@ echo "compiler: ghcjs" > cabal.config cabal configure -fexample -ftest-client cabal build-cd example/todo-make ~~~ -The above builds the TODO application, compresses it with closure, and builds the test client.+The above builds the TODO application and the test client. Next, install [selenium-server-standalone](http://www.seleniumhq.org/download/) (also from [npm](https://www.npmjs.com/package/selenium-server-standalone-jar)). Then, build the [hspec-webdriver](https://hackage.haskell.org/package/hspec-webdriver) test suite using GHC (not-GHCJS). I use stack for this, although you can use cabal too if you like.+GHCJS). I use stack for this, although you can use cabal too if you like. Also, at the moment, the prerelease+of the react-intl library must be installed from npm. ~~~-cd test/spec+cd test/client+npm install react-intl@next+cd ../spec stack build ~~~ -Finally, start selenium-server-standalone and execute the test suite. It must be started from the-`test/spec` directory, otherwise it does not find the correct javascript files.+Finally, start selenium-server-standalone and execute the test suite. Make sure you also have+closure installed, since the test suite will compress the todo app before testing it. It must be+started from the `test/spec` directory, otherwise it does not find the correct javascript files. ~~~ stack exec react-flux-spec
example/README.md view
@@ -10,7 +10,7 @@ When reading the code for the example application, you should start with `TodoStore.hs`. Next, look at `TodoDispatcher.hs` and `TodoViews.hs`. Finally, you can look at `TodoComponents.hs` and-`Main.hs`.+`Main.hs` and `NodeMain.hs`. ### Build @@ -21,7 +21,9 @@ cabal build ~~~ -The result of this build is a file `dist/build/todo/todo.jsexe/all.js`. There is a file+### TODO in the browser++A result of this build is a file `dist/build/todo/todo.jsexe/all.js`. There is a file `example/todo/todo-dev.html` which loads this `all.js` file directly from the `dist` directory, so you can open `todo-dev.html` after building. @@ -35,7 +37,18 @@ ~~~ This produces a file `js-build/todo.min.js` which is only 500 kibibytes which when compressed with-gzip is 124 kibibytes.+gzip is 124 kibibytes. You can then open `example/todo/todo.html` which loads this minimized javascript.++### TODO in node++`NodeMain.hs` is a separate main module which instead of rendering the TODO example application into the DOM,+it renders it to a string and then displays it. To execute this, run++~~~+cd example/todo+npm install react@0.13.3+node run-in-node.js+~~~ ### Testing
example/todo/Makefile view
@@ -3,9 +3,9 @@ js-build/todo.js: ../../dist/build/todo/todo.jsexe/all.js mkdir -p js-build- echo "(function(global,React) {" > js-build/todo.js+ echo "(function(global,React,ReactDOM) {" > js-build/todo.js cat ../../dist/build/todo/todo.jsexe/all.js >> js-build/todo.js- echo "})(this, window['React']);" >> js-build/todo.js+ echo "})(window, window['React'], window['ReactDOM']);" >> js-build/todo.js sed -i 's/goog.provide.*//' js-build/todo.js sed -i 's/goog.require.*//' js-build/todo.js # https://github.com/ghcjs/shims/issues/21
+ example/todo/NodeMain.hs view
@@ -0,0 +1,6 @@+import React.Flux+import TodoViews+import qualified Data.Text.IO as T++main :: IO ()+main = reactRenderToString True todoApp () >>= T.putStrLn
+ example/todo/run-in-node.js view
@@ -0,0 +1,2 @@+React = require("react");+require("../../dist/build/todo-node/todo-node.jsexe/all.js");
example/todo/todo-dev.html view
@@ -7,7 +7,8 @@ </head> <body> <section id="todoapp"/>- <script src="https://fb.me/react-0.13.3.js"></script>+ <script src="https://fb.me/react-0.14.0-rc1.js"></script>+ <script src=" https://fb.me/react-dom-0.14.0-rc1.js"></script> <script src="../../dist/build/todo/todo.jsexe/all.js"></script> </body> </html>
example/todo/todo.html view
@@ -7,7 +7,8 @@ </head> <body> <section id="todoapp"/>- <script src="https://fb.me/react-0.13.3.js"></script>+ <script src="https://fb.me/react-0.14.0-rc1.js"></script>+ <script src=" https://fb.me/react-dom-0.14.0-rc1.js"></script> <script src="js-build/todo.min.js"></script> </body> </html>
+ jsbits/callback.js view
@@ -0,0 +1,9 @@+function hsreact$mk_arguments_callback(f) {+ return function() {+ var args = new Array(arguments.length);+ for (var i = 0; i < arguments.length; i++) {+ args[i] = arguments[i];+ }+ f(args);+ };+}
jsbits/views.js view
@@ -130,3 +130,14 @@ return React['createClass'](cl); }++//React 0.14 introduced React.Children.toArray. Also, to be able to run template haskell splices,+//we need to defend againsg React not being defined.+var hsreact$children_to_array = typeof React !== "object" ? null : (React['Children']['toArray'] ? React['Children']['toArray'] :+ (function (children) {+ var ret = [];+ React['Children']['forEach'](children, function(x) {+ ret.push(x);+ });+ return ret;+ }));
react-flux.cabal view
@@ -1,5 +1,5 @@ name: react-flux-version: 0.9.4+version: 1.0.0 synopsis: A binding to React based on the Flux application architecture for GHCJS category: Web homepage: https://bitbucket.org/wuzzeb/react-flux@@ -18,15 +18,16 @@ example/css/bg.png, example/todo/Makefile, example/todo/*.hs,- example/todo/*.html+ example/todo/*.html,+ example/todo/run-in-node.js, example/routing/*.hs, example/routing/*.html,- test/client/test-client.html,+ test/client/*.html,+ test/client/msgs/*.json,+ test/client/msgs/*.xml, test/spec/react-flux-spec.cabal,- test/spec/Spec.hs, test/spec/stack.yaml,- test/spec/TestClientSpec.hs,- test/spec/TodoSpec.hs+ test/spec/*.hs source-repository head type: mercurial@@ -44,7 +45,10 @@ hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010- js-sources: jsbits/views.js jsbits/store.js jsbits/export.js+ js-sources: jsbits/views.js+ jsbits/store.js+ jsbits/export.js+ jsbits/callback.js exposed-modules: React.Flux React.Flux.DOM@@ -53,6 +57,7 @@ React.Flux.Internal React.Flux.Addons.React React.Flux.Addons.Bootstrap+ React.Flux.Addons.Intl other-modules: React.Flux.Views React.Flux.Store@@ -76,6 +81,10 @@ , mtl >= 2.1 , aeson >= 0.8 , text >= 1.2+ , time >= 1.5+ , unordered-containers+ , bytestring+ , template-haskell >= 2.10 if impl(ghcjs) build-depends: ghcjs-base@@ -93,7 +102,20 @@ , react-flux , deepseq -executable test-client+executable todo-node+ if !flag(example)+ Buildable: False+ ghc-options: -Wall++ default-language: Haskell2010+ hs-source-dirs: example/todo+ main-is: NodeMain.hs+ build-depends: base+ , react-flux+ , deepseq+ , text++executable test-client-13 if !flag(test-client) Buildable: False ghc-options: -Wall@@ -101,9 +123,29 @@ default-language: Haskell2010 hs-source-dirs: test/client- main-is: TestClient.hs+ other-modules: TestClient+ main-is: TestClient13.hs build-depends: base , react-flux+ , time+ , deepseq+ if impl(ghcjs)+ build-depends: ghcjs-base++executable test-client-14+ if !flag(test-client)+ Buildable: False+ ghc-options: -Wall+ --cpp-options: -DGHCJS_BROWSER++ default-language: Haskell2010+ hs-source-dirs: test/client+ other-modules: TestClient+ main-is: TestClient14.hs+ build-depends: base+ , react-flux+ , time+ , deepseq if impl(ghcjs) build-depends: ghcjs-base
src/React/Flux.hs view
@@ -19,14 +19,25 @@ -- which calls 'reactRender' and initializes any AJAX load calls to the backend. The source package -- contains some <https://bitbucket.org/wuzzeb/react-flux/src/tip/example/ example applications>. ----- __Deployment__: Care has been taken to make sure closure with ADVANCED_OPTIMIZATIONS correctly--- minimizes a react-flux application. No externs are needed, instead all you need to do is provide--- or protect the @React@ variable. The TODO example does this as follows:+-- __Web Deployment__: 'reactRender' is used to render your application into the DOM.+-- Care has been taken to make sure closure with ADVANCED_OPTIMIZATIONS correctly+-- minimizes a react-flux application. No externs are needed, instead all you need to do is+-- protect the @React@ variable (and @ReactDOM@ if you are using version >= 0.14). The TODO example+-- does this as follows: ----- >(function(global, React) {+-- >(function(global, React, ReactDOM) { -- >contents of all.js--- >})(this, window['React']);+-- >})(window, window['React'], window['ReactDOM']); --+-- __Node Deployment__: 'reactRenderToString' is used to render the application to a string when+-- running in node (not the browser). To execute with node, you need to get @global.React@ (and+-- @global.ReactDOM@ for 0.14) before executing all.js. The TODO example application does this by+-- creating a file @run-in-node.js@ with the contents+--+-- >React = require("react");+-- >ReactDOM = require("react-dom");+-- >require("../../dist/build/todo-node/todo-node.jsexe/all.js");+-- -- __Testing__: I use the following approach to test my react-flux application. First, I use unit -- testing to test the dispatcher and store 'transform' functions. Since the dispatcher and the -- store transform are just data manipulation, existing Haskell tools like hspec, QuickCheck,@@ -77,12 +88,14 @@ -- * Main , reactRender+ , reactRenderToString -- * Performance -- $performance ) where import Data.Typeable (Typeable)+import Data.Text (Text) import React.Flux.Views import React.Flux.DOM@@ -91,14 +104,15 @@ import React.Flux.Store #ifdef __GHCJS__-import GHCJS.Types (JSString)+import GHCJS.Types (JSString, JSRef)+import GHCJS.Marshal (fromJSRef) #endif ---------------------------------------------------------------------------------------------------- -- reactRender has two versions ---------------------------------------------------------------------------------------------------- --- | Render your React application into the DOM.+-- | Render your React application into the DOM. Use this from your @main@ function, and only in the browser. reactRender :: Typeable props => String -- ^ The ID of the HTML element to render the application into. -- (This string is passed to @document.getElementById@)@@ -113,12 +127,46 @@ js_ReactRender e (toJSString htmlId) foreign import javascript unsafe- "React['render']($1, document.getElementById($2))"+ "(typeof ReactDOM === 'object' ? ReactDOM : React)['render']($1, document.getElementById($2))" js_ReactRender :: ReactElementRef -> JSString -> IO () #else reactRender _ _ _ = return ()++#endif++-- | Render your React application to a string using either @React.renderToString@ if the first+-- argument is false or @React.renderToStaticMarkup@ if the first argument is true.+-- Use this only on the server when running with node.+reactRenderToString :: Typeable props+ => Bool -- ^ Render to static markup? If true, this won't create extra DOM attributes+ -- that React uses internally.+ -> ReactView props -- ^ A single instance of this view is created+ -> props -- ^ the properties to pass to the view+ -> IO Text++#ifdef __GHCJS__++reactRenderToString includeStatic rc props = do+ (e, _) <- mkReactElement id (return []) $ view rc props mempty+ sRef <- (if includeStatic then js_ReactRenderStaticMarkup else js_ReactRenderToString) e+ --return sRef+ --return $ JSS.unpack sRef+ mtxt <- fromJSRef sRef+ maybe (error "Unable to convert string return to Text") return mtxt++foreign import javascript unsafe+ "(typeof ReactDOM === 'object' ? ReactDOM : React)['renderToString']($1)"+ js_ReactRenderToString :: ReactElementRef -> IO JSRef++foreign import javascript unsafe+ "(typeof ReactDOM === 'object' ? ReactDOM : React)['renderToStaticMarkup']($1)"+ js_ReactRenderStaticMarkup :: ReactElementRef -> IO JSRef++#else++reactRenderToString _ _ _ = return "" #endif
src/React/Flux/Addons/Bootstrap.hs view
@@ -15,11 +15,18 @@ -- | A bootstrap <http://react-bootstrap.github.io/components.html component>. For example, -- -- >bootstrap_ "Alert" [ "bsStyle" $= "danger"--- > , callback "onDismiss" (const $ dispatch CloseAlert)+-- > , callback "onDismiss" $ dispatch CloseAlert -- > ] $ -- > p_ "Hello, World!"+-- >+-- >bootstrap_ "Nav" [ "activeKey" @= (1 :: Int)+-- > , callback "onSelect" $ \(i :: Int) -> dispatch $ TabChange i+-- > ] $ do+-- > bootstrap_ "NavItem" ["eventKey" @= (1 :: Int)] "Item 1"+-- > bootstrap_ "NavItem" ["eventKey" @= (2 :: Int)] "Item 2"+-- > bootstrap_ "NavItem" ["eventKey" @= (3 :: Int)] "Item 3" bootstrap_ :: String- -- ^ The component name. Uses @window['ReactBootstrap'][name]@ to find the class, so+ -- ^ The component name. Uses @window[\'ReactBootstrap\'][name]@ to find the class, so -- the name can be anything exported to the @window.ReactBoostrap@ object. -> [PropertyOrHandler eventHandler] -- ^ Properties and callbacks to pass to the ReactBootstrap class. You can use 'callback'
+ src/React/Flux/Addons/Intl.hs view
@@ -0,0 +1,582 @@+-- | Bindings to the <http://formatjs.io/react/ ReactIntl> library, which allows easy formatting of+-- numbers, dates, times, relative times, pluralization, and translated messages. This library can+-- be used for formatting and pluralization even if you intend to present your application in a single+-- language and locale.+--+-- These bindings are for the 2.0 version of ReactIntl which is currently just a+-- pre-release, and due to how react-flux works, it also requires React 0.14. For temporary documentation,+-- see <https://github.com/yahoo/react-intl/issues/162 issue62>. Because this is a binding to a+-- pre-release, the API below might change! I consider it unlikely, but if a change is required I will+-- violate the PVP and not increment the major number, just the minor number.+--+-- To use these bindings, you need to provide the @ReactIntl@ variable. In the browser you can just+-- load the @react-intl.min.js@ script onto the page so that @window.ReactIntl@ exists. If you are+-- running in node, execute @ReactIntl = require(\"ReactIntl\");@ so that @global.ReactIntl@+-- exists. When compiling with closure, protect the ReactIntl variable as follows:+--+-- >(function(global, React, ReactDOM, ReactIntl) {+-- >contents of all.js+-- >})(window, window['React'], window['ReactDOM'], window['ReactIntl']);+--+-- __Using with a single locale and no translations__. If you intend to present your application in+-- a single language, you can still use this module for formatting. Add a call to 'intlProvider_'+-- to the top of your app with a hard-coded locale and @Nothing@ for the messages. You can then use+-- anything in the /Formatting/ section like 'int_', 'relativeTo_', and 'message', where 'message'+-- will just always use the default message provided in the source code (helpful for templating).+-- If you want to specify the locale so dates and numbers are formatted in the user's locale, it is+-- strongly recommended to set the locale from the server based on the @Accept-Language@ header+-- and/or a user setting so that the page as a whole is consistint. I have the server set a+-- variable on @window@ for the locale to use, and then pass that locale into 'intlProvider_'.+--+-- __Translations__. The react-intl philosophy is that messages should be defined in the source+-- code instead of kept in a separate file. To support translations, a tool (in this case Template+-- Haskell) is used to extract the messages from the source code into a file given to the+-- translators. The result of the translation is then used to replace the default message given in+-- the source code.+--+-- 1. Use the functions in the /Formatting/ section like 'int_', 'relativeTo_', and 'message'+-- inside your rendering functions.+--+-- 2. At the bottom of each file which contains messages, add a call to 'writeIntlMessages'. This+-- is a template haskell function which during compilation will produce a file containing all the+-- messages found within the haskell module.+--+-- 3. Give these message files to your translators. The translation results will then need to be+-- converted into javascript files in the format expected by ReactIntl, which is a javascript+-- object with keys the 'MessageId's and value the translated message. For example, each translation+-- could result in a javascript file such as the following:+--+-- @+-- window.myMessages = window.myMessages || {};+-- window.myMessages["fr-FR"] = {+-- "num_photos": "{name} {numPhotos, plural, =0 {n'a pas pris de photographie.} =1 {a pris une photographie.} other {a pris # photographies.}",+-- ...+-- };+-- @+--+-- 4. Based on the @Accept-Language@ header and/or a user setting, the server includes the+-- appropriate translation javascript file and sets a variable on window containing the locale to+-- use. Note that no translation javascript file is needed if the default messages from the+-- source code should be used.+--+-- @+-- \<script type="text\/javascript"\>window.myIntialConfig = { "locale": "fr-FR" };\<\/script\>+-- \<script src="path\/to\/translations.fr-FR.js"\>\<\/script\>+-- @+--+-- 5. Add a call to 'intlProvider_' at the top of your application, passing the locale and the+-- messages.+--+-- @+-- foreign import javascript unsafe+-- "$r = window[\'myInitialConfig\'][\'locale\']"+-- js_initialLocale :: JSString+--+-- foreign import javascript unsafe+-- "window[\'myMessages\'] ? window[\'myMessages\'][$1] : null"+-- js_myMessages :: JSString -> JSRef+--+-- myApp :: ReactView ()+-- myApp = defineView "my application" $ \() -> do+-- intlProvider_ (JSString.unpack js_initialLocale) (Just $ js_myMessages js_initialLocale) $+-- ...+-- @+--+-- If you want to allow changing the locale without a page refresh, just load the initial+-- locale into a store and use a controller-view to pass the locale and lookup the messages+-- for 'intlProvider_'.++{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+module React.Flux.Addons.Intl(+ intlProvider_++ -- * Formatting+ + -- ** Numbers+ , int_+ , double_+ , formattedNumber_++ -- ** Dates and Times+ , DayFormat(..)+ , shortDate+ , day_+ , TimeFormat(..)+ , shortDateTime+ , utcTime_+ , formattedDate_++ -- ** Relative Times+ , relativeTo_+ , formattedRelative_++ -- ** Plural+ , plural_++ -- ** Messages+ , MessageId+ , message+ , message'+ , htmlMsg+ , htmlMsg'++ -- * Translation+ , Message(..)+ , writeIntlMessages+ , intlFormatJson+ , intlFormatJsonWithoutDescription+ , intlFormatAndroidXML+) where++import Control.Monad (when, forM_)+import Data.Aeson (Object, Value(Object))+import Data.Char (ord, isPrint)+import Data.List (sortBy)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid ((<>))+import Data.Ord (comparing)+import Data.Time+import Language.Haskell.TH (runIO, Q, Loc, location, ExpQ)+import Language.Haskell.TH.Syntax (liftString, qGetQ, qPutQ, reportWarning, Dec)+import React.Flux+import System.IO (withFile, IOMode(..))+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++#ifdef __GHCJS__++import GHCJS.Types (JSRef)++foreign import javascript unsafe+ "$r = ReactIntl['IntlProvider']"+ js_intlProvider :: JSRef++foreign import javascript unsafe+ "$r = ReactIntl['FormattedNumber']"+ js_formatNumber :: JSRef++foreign import javascript unsafe+ "$r = ReactIntl['FormattedDate']"+ js_formatDate :: JSRef++foreign import javascript unsafe+ "$r = ReactIntl['FormattedRelative']"+ js_formatRelative :: JSRef++foreign import javascript unsafe+ "$r = ReactIntl['FormattedPlural']"+ js_formatPlural :: JSRef++foreign import javascript unsafe+ "$r = ReactIntl['FormattedMessage']"+ js_formatMsg :: JSRef++foreign import javascript unsafe+ "$r = ReactIntl['FormattedHTMLMessage']"+ js_formatHtmlMsg :: JSRef++foreign import javascript unsafe+ "$r = (new Date($1, $2-1, $3))"+ js_mkDate :: Int -> Int -> Int -> JSRef++-- | Convert a day to a javascript Date+dayToRef :: Day -> JSRef+dayToRef day = js_mkDate (fromIntegral y) m d+ where+ (y, m, d) = toGregorian day++foreign import javascript unsafe+ "$r = (new Date(Date.UTC($1, $2-1, $3, $4, $5, $6, $7)))"+ js_mkDateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> JSRef++-- | Convert a UTCTime to a javascript date object.+timeToRef :: UTCTime -> JSRef+timeToRef (UTCTime uday time) = js_mkDateTime (fromIntegral year) month day hour minute sec micro+ where+ (year, month, day) = toGregorian uday+ TimeOfDay hour minute pSec = timeToTimeOfDay time+ (sec, fracSec) = properFraction pSec+ micro = round $ fracSec * 1000000++#else++type JSRef = ()++js_intlProvider :: JSRef+js_intlProvider = ()++js_formatNumber :: JSRef+js_formatNumber = ()++js_formatDate :: JSRef+js_formatDate = ()++js_formatRelative :: JSRef+js_formatRelative = ()++js_formatPlural :: JSRef+js_formatPlural = ()++js_formatMsg :: JSRef+js_formatMsg = ()++js_formatHtmlMsg :: JSRef+js_formatHtmlMsg = ()++dayToRef :: Day -> JSRef+dayToRef _ = ()++timeToRef :: UTCTime -> JSRef+timeToRef _ = ()++#endif++-- | Use the IntlProvider to set the @locale@, @formats@, and @messages@ property.+intlProvider_ :: String -- ^ the locale to use+ -> Maybe JSRef+ -- ^ A reference to translated messages, which must be an object with keys+ -- 'MessageId' and value the translated message. Set this as Nothing if you are not using+ -- translated messages, since either @Nothing@ or a null JSRef will cause the messages+ -- from the source code to be used.+ -> Maybe Object+ -- ^ An object to use for the @formats@ parameter which allows custom formats. I+ -- suggest you use custom formats only for messages. Custom formats for numbers+ -- and dates not in a message is better done by writing a small Haskell utility+ -- function wrapping for example 'formattedNumber_'.+ -> ReactElementM eventHandler a -- ^ The children of this element. All descendents will use the given locale and messages.+ -> ReactElementM eventHandler a+intlProvider_ locale mmsgs mformats = foreignClass js_intlProvider props+ where+ props = catMaybes [ Just ("locale" @= locale)+ , (property "messages") <$> mmsgs+ , (property "formats" . Object) <$> mformats+ ]++--------------------------------------------------------------------------------+--- Numbers+--------------------------------------------------------------------------------++-- | Format an integer using 'formattedNumber_' and the default style.+int_ :: Int -> ReactElementM eventHandler ()+int_ i = formattedNumber_ [ "value" @= i ]++-- | Format a double using 'formattedNumber_' and the default style.+double_ :: Double -> ReactElementM eventHandler ()+double_ d = formattedNumber_ [ "value" @= d ]++-- | A <http://formatjs.io/react/#formatted-number FormattedNumber> which allows arbitrary properties+-- and therefore allows control over the style and format of the number. The accepted properties are+-- any options supported by+-- <https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/NumberFormat Intl.NumberFormat>.+formattedNumber_ :: [PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()+formattedNumber_ props = foreignClass js_formatNumber props mempty++--------------------------------------------------------------------------------+-- Date/Time+--------------------------------------------------------------------------------++-- | How to display a date. Each non-Nothing component will be displayed while the Nothing+-- components will be ommitted. If everything is nothing, then it is assumed that year, month, and+-- day are each numeric.+--+-- These properties coorespond directly the options accepted by+-- <https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DateTimeFormat Intl.DateTimeFormat>.+data DayFormat = DayFormat {+ weekdayF :: Maybe String -- ^ possible values are narrow, short, and long+ , eraF :: Maybe String -- ^ possible values are narrow, short, and long+ , yearF :: Maybe String -- ^ possible values are numeric and 2-digit+ , monthF :: Maybe String -- ^ possible values are numeric, 2-digit, narrow, short, and long+ , dayF :: Maybe String -- ^ possible values are numeric and 2-digit+} deriving Show++-- | Convert a format to the properties accepted by FormattedDate+dayFtoProps :: DayFormat -> [PropertyOrHandler handler]+dayFtoProps (DayFormat w e y m d) = catMaybes+ [ ("weekday"@=) <$> w+ , ("era"@=) <$> e+ , ("year"@=) <$> y+ , ("month"@=) <$> m+ , ("day"@=) <$> d+ ]++-- | A short day format, where month is \"short\" and year and day are \"numeric\".+shortDate :: DayFormat+shortDate = DayFormat+ { weekdayF = Nothing+ , eraF = Nothing+ , yearF = Just "numeric"+ , monthF = Just "short"+ , dayF = Just "numeric"+ }++-- | How to display a time. Each non-Nothing component will be displayed while Nothing components+-- will be ommitted.+--+-- These properties coorespond directly the options accepted by+-- <https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DateTimeFormat Intl.DateTimeFormat>.+data TimeFormat = TimeFormat {+ hourF :: Maybe String -- ^ possible values are numeric and 2-digit+ , minuteF :: Maybe String -- ^ possible values are numeric and 2-digit+ , secondF :: Maybe String -- ^ possible values are numeric and 2-digit+ , timeZoneNameF :: Maybe String -- ^ possible values are short and long+} deriving Show++-- | Convert a time format to properties for the FormattedDate element+timeFtoProps :: TimeFormat -> [PropertyOrHandler handler]+timeFtoProps (TimeFormat h m s t) = catMaybes+ [ ("hour"@=) <$> h+ , ("minute"@=) <$> m+ , ("second"@=) <$> s+ , ("timeZoneName"@=) <$> t+ ]++-- | A default date and time format, using 'shortDate' and then numeric for hour, minute, and+-- second.+shortDateTime :: (DayFormat, TimeFormat)+shortDateTime = (shortDate, TimeFormat+ { hourF = Just "numeric"+ , minuteF = Just "numeric"+ , secondF = Just "numeric"+ , timeZoneNameF = Nothing+ })++-- | Display a 'Day' in the given format using the @FormattedDate@ class and then wrap it in a+-- HTML5 <https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time time> element.+day_ :: DayFormat -> Day -> ReactElementM eventHandler ()+day_ fmt day = time_ [property "dateTime" dateRef] $ foreignClass js_formatDate props mempty+ where+ dateRef = dayToRef day+ props = property "value" dateRef : dayFtoProps fmt++-- | Display a 'UTCTime' using the given format. Despite giving the time in UTC, it will be+-- displayed to the user in their current timezone. In addition, wrap it in a HTML5+-- <https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time time> element.+utcTime_ :: (DayFormat, TimeFormat) -> UTCTime -> ReactElementM eventHandler ()+utcTime_ (dayFmt, timeF) t = time_ [property "dateTime" timeRef] $ foreignClass js_formatDate props mempty+ where+ timeRef = timeToRef t+ props = property "value" timeRef : (dayFtoProps dayFmt ++ timeFtoProps timeF)++-- | A raw <http://formatjs.io/react/#formatted-date FormattedDate> class which allows custom+-- properties to be passed. The given 'Day' or 'UTCTime' will be converted to a javascript Date+-- object and passed in the @value@ property. The remaining properties can be any properties that+-- <https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DateTimeFormat Intl.DateTimeFormat>+-- accepts. For example, you could pass in \"timeZone\" to specify a specific timezone to display.+formattedDate_ :: Either Day UTCTime -> [PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()+formattedDate_ t props = foreignClass js_formatDate (valProp:props) mempty+ where+ valProp = property "value" $ either dayToRef timeToRef t+++-- | Display the 'UTCTime' as a relative time. In addition, wrap the display in a HTML5+-- <https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time time> element.+relativeTo_ :: UTCTime -> ReactElementM eventHandler ()+relativeTo_ t = time_ [property "dateTime" timeRef] $ foreignClass js_formatRelative [property "value" timeRef] mempty+ where+ timeRef = timeToRef t++-- | Format the given UTCTime using the <http://formatjs.io/react/#formatted-relative FormattedRelative>+-- class to display a relative time to now. The given 'UTCTime' is passed in the value property.+-- The supported style/formatting properties are \"units\" which can be one of second, minute, hour,+-- day, month, or year and \"style\" which if given must be numeric.+formattedRelative_ :: UTCTime -> [PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()+formattedRelative_ t props = foreignClass js_formatRelative (property "value" (timeToRef t) : props) mempty++--------------------------------------------------------------------------------+-- Plural+--------------------------------------------------------------------------------++-- | A simple plural formatter useful if you do not want the full machinery of messages. This does+-- not support translation, for that you must use messages which via the ICU message syntax support+-- pluralization. The properties passed to 'plural_' must be @value@, and then at least one of the+-- properties from @other@, @zero@, @one@, @two@, @few@, @many@.+plural_ :: [PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()+plural_ props = foreignClass js_formatPlural props mempty++--------------------------------------------------------------------------------+-- Messages+--------------------------------------------------------------------------------++-- | An identifier for a message, must be globally unique.+type MessageId = T.Text++-- | A message.+data Message = Message {+ msgDescription :: T.Text -- ^ A description intended to provide context for translators.+ , msgDefaultMsg :: T.Text -- ^ The default message written in <http://formatjs.io/guides/message-syntax/ ICU message syntax>.+} deriving Show++-- | This is the type stored in the Q monad with qGetQ and qPutQ+type MessageMap = H.HashMap MessageId (Message, Loc)++-- | Utility function to build the properties for FormattedMessage.+messageToProps :: MessageId -> Message -> [PropertyOrHandler eventHandler] -> [PropertyOrHandler eventHandler]+messageToProps i (Message desc m) props = ["id" @= i, "description" @= desc, "defaultMessage" @= m, nestedProperty "values" props]++-- | Render a message and also record it during compilation. This template haskell+-- splice produces an expression of type @[PropertyOrHandler eventHandler] -> ReactElementM eventHandler+-- ()@, which should be passed the values for the message. For example,+--+-- >li_ ["id" $= "some-id"] $+-- > $(message "num_photos" "{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}} {takenAgo}.")+-- > [ "name" $= "Neil Armstrong"+-- > , "numPhotos" @= (100 :: Int)+-- > , elementProperty "takenAgo" $ relativeTo_ (UTCTime (fromGregorian 1969 7 20) (2*60*60 + 56*60))+-- > ]+--+-- This will first lookup the 'MessageId' (in this case @num_photos@) in the @messages@ parameter passed to 'intlProvider_'.+-- If no messages were passed, 'intlProvider_' was not called, or the 'MessageId' was not found, the default message is used.+--+-- In my project, I create a wrapper around 'message' which sets the 'MessageId' as the sha1 hash of+-- the message. I did not implement it in react-flux because I did not want to add cryptohash as a+-- dependency. For example,+--+-- >import Crypto.Hash (hash, SHA1)+-- >import qualified Data.Text as T+-- >import qualified Data.Text.Encoding as T+-- >+-- >msg :: T.Text -> ExpQ+-- >msg txt = message (T.pack $ show (hash (T.encodeUtf8 txt) :: Digest SHA1)) txt+message :: MessageId+ -> T.Text -- ^ The default message written in <http://formatjs.io/guides/message-syntax/ ICU message syntax>.+ -- This message is used if no translation is found, and is also the message given to the translators.+ -> ExpQ --Q (TExp ([PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()))+message ident m = formattedMessage [|js_formatMsg|] ident $ Message "" m++-- | Similar to 'message' but use a @FormattedHTMLMessage@ which allows HTML inside the message. It+-- is recomended that you instead use 'message' together with 'elementProperty' to include rich text+-- inside the message. This splice produces a value of type @[PropertyOrHandler+-- eventHandler] -> ReactElementM eventHandler ()@, the same as 'message'.+htmlMsg :: MessageId+ -> T.Text -- ^ default message written in ICU message syntax+ -> ExpQ+htmlMsg ident m = formattedMessage [|js_formatHtmlMsg|] ident $ Message "" m++-- | A variant of 'message' which allows you to specify some context for translators.+message' :: MessageId+ -> T.Text -- ^ A description indented to provide context for translators+ -> T.Text -- ^ The default message written in ICU message syntax+ -> ExpQ --Q (TExp ([PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()))+message' ident descr m = formattedMessage [|js_formatMsg|] ident $ Message descr m++-- | A variant of 'htmlMsg' that allows you to specify some context for translators.+htmlMsg' :: MessageId+ -> T.Text -- ^ A description intended to provide context for translators+ -> T.Text -- ^ The default message written in ICU message syntax+ -> ExpQ+htmlMsg' ident descr m = formattedMessage [|js_formatHtmlMsg|] ident $ Message descr m++-- | Utility function for messages+formattedMessage :: ExpQ -> MessageId -> Message -> ExpQ --Q (TExp ([PropertyOrHandler eventHandler] -> ReactElementM eventHandler ()))+formattedMessage cls ident m = do+ curLoc <- location+ mmap :: MessageMap <- fromMaybe H.empty <$> qGetQ+ case H.lookup ident mmap of+ Just (prevMsg, prevLoc) | msgDefaultMsg m /= msgDefaultMsg prevMsg -> do+ reportWarning $ unlines+ [ "Message with id " ++ (T.unpack ident) ++ " appears twice with different messages"+ , show curLoc ++ ": " ++ (T.unpack $ msgDefaultMsg m)+ , show prevLoc ++ ": " ++ (T.unpack $ msgDefaultMsg prevMsg)+ ]+ _ -> return ()+ qPutQ $ H.insert ident (m, curLoc) mmap++ let liftText x = [| T.pack $(liftString $ T.unpack x)|]+ liftedMsg = [| Message $(liftText $ msgDescription m) $(liftText $ msgDefaultMsg m) |]+ [|\vals -> foreignClass $cls (messageToProps $(liftText ident) $liftedMsg vals) mempty |]++-- | Perform an arbitrary IO action on the accumulated messages at compile time, which usually+-- should be to write the messages to a file. Despite producing a value of type @Q [Dec]@,+-- no declarations are produced. Instead, this is purly to allow IO to happen. A call to this+-- function should be placed at the bottom of the file, since it only will output messages that+-- appear above the call. Also, to provide consistency, I suggest you create a utility wrapper+-- around this function. For example,+--+-- >{-# LANGUAGE TemplateHaskell #-}+-- >module MessageUtil where+-- >+-- >import Language.Haskell.TH+-- >import Language.Haskell.TH.Syntax+-- >import React.Flux.Addons.Intl+-- >+-- >writeMessages :: String -> Q [Dec]+-- >writeMessages name = writeIntlMessages (intlFormatJson $ "some/diretory/" ++ name ++ ".json")+--+-- Note that all paths in template haskell are relative to the directory containing the @.cabal@+-- file. You can then use this as follows:+--+-- >{-# LANGUAGE TemplateHaskell #-}+-- >module SomeViews where+-- >+-- >import React.Flux+-- >import React.Flux.Addons.Intl+-- >import MessageUtil+-- >+-- >someView :: ReactView ()+-- >someView = defineView .... use $(message) in render ...+-- >+-- >anotherView :: ReactView ()+-- >anotherView = defineView ... use $(message) in render ...+-- >+-- >writeMessages "some-views"+writeIntlMessages :: (H.HashMap MessageId Message -> IO ()) -> Q [Dec]+writeIntlMessages f = do+ mmap :: MessageMap <- fromMaybe H.empty <$> qGetQ+ runIO $ f $ fmap fst mmap+ return []++-- | Format messages as json. The format is an object where keys are the 'MessageId's, and the+-- value is an object with two properties, @message@ and optionally @description@. This happens to+-- the the same format as <https://developer.chrome.com/extensions/i18n-messages chrome>, although+-- the syntax of placeholders uses ICU message syntax instead of chrome's syntax. This does not+-- pretty-print the JSON, but I suggest before adding these messages in source control you pretty+-- print and sort by MessageIds so diffs are easy to read. This can be done with the+-- @aeson-pretty@ package, but I did not want to add it as a dependency.+intlFormatJson :: FilePath -> H.HashMap MessageId Message -> IO ()+intlFormatJson fp mmap = BL.writeFile fp $ Aeson.encode $ Aeson.Object $ fmap f mmap+ where+ f (Message "" m) = Aeson.object [(Aeson..=) "message" m]+ f (Message desc m) = Aeson.object [(Aeson..=) "message" m, (Aeson..=) "description" desc]++-- | Format messages as json, ignoring the description. The format is an object where the keys are+-- the 'MessageId's and the value is the message string. This format is used by many javascript+-- libraries, so many translation tools exist.+intlFormatJsonWithoutDescription :: FilePath -> H.HashMap MessageId Message -> IO ()+intlFormatJsonWithoutDescription fp mmap = BL.writeFile fp $ Aeson.encode $ Aeson.Object $ fmap f mmap+ where+ f (Message _ m) = Aeson.String m++-- | Format messages in <http://developer.android.com/guide/topics/resources/string-resource.html Android XML>+-- format, but just using strings. String arrays and plurals are handled in the ICU message,+-- instead of in the XML. There are many utilities to translate these XML messages, and the format has the+-- advantage that it can include the descriptions as well as the messages. Also, the messages are+-- sorted by 'MessageId' so that if the output is placed in source control the diffs are easy to+-- review.+intlFormatAndroidXML :: FilePath -> H.HashMap MessageId Message -> IO ()+intlFormatAndroidXML fp mmap = withFile fp WriteMode $ \handle -> do+ B.hPut handle "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ B.hPut handle "<resources>\n"+ let putText = B.hPut handle . T.encodeUtf8++ let msgs = sortBy (comparing fst) $ H.toList mmap+ forM_ msgs $ \(ident, m) -> do+ when (msgDescription m /= "") $+ putText $ "<!-- " <> escapeForXml (msgDescription m) <> " -->\n"+ -- TODO: escape!!+ putText $ "<string name=\"" <> escapeForXml ident <> "\">" <> escapeForXml (msgDefaultMsg m) <> "</string>\n"+ B.hPut handle "</resources>\n"++escapeForXml :: T.Text -> T.Text+escapeForXml = T.concatMap f+ where+ f '<' = "<"+ f '>' = ">"+ f '&' = "&"+ f '"' = """+ f '\'' = "'"+ f x | isPrint x || x == '\n' = T.singleton x+ f x = "&#" <> T.pack (show $ ord x) <> ";"
src/React/Flux/Addons/React.hs view
@@ -5,8 +5,6 @@ module React.Flux.Addons.React ( -- * Animation cssTransitionGroup- , CSSTransitionProps(..)- , defaultTransitionProps -- * Perf , PerfAction(..)@@ -17,7 +15,6 @@ import Control.DeepSeq (NFData) import Control.Monad (forM_)-import Data.Typeable (Typeable) import GHC.Generics (Generic) import React.Flux @@ -25,35 +22,15 @@ import GHCJS.Types (JSRef, JSString) #endif --- | The properties for the CSS Transition Group.-data CSSTransitionProps = CSSTransitionProps- { transitionName :: String- , transitionAppear :: Bool- , transitionEnter :: Bool- , transitionLeave :: Bool- } deriving (Typeable)---- | Default properties for CSS Transition Group, using \"react-transition\" as the transition name.-defaultTransitionProps :: CSSTransitionProps-defaultTransitionProps = CSSTransitionProps- { transitionName = "react-transition"- , transitionAppear = False- , transitionEnter = True- , transitionLeave = True- }---- | The <https://facebook.github.io/react/docs/animation.html ReactCSSTransitionGroup> element. At--- the moment, only the high-level API is supported.-cssTransitionGroup :: CSSTransitionProps -> ReactElementM eventHandler a -> ReactElementM eventHandler a+-- | The <https://facebook.github.io/react/docs/animation.html ReactCSSTransitionGroup> element.+-- For example in React 0.14,+--+-- >cssTransitionGroup ["transitionName" $= "example", transitionAppear @= True, transitionAppearTimeout @= (100 :: Int)] $+-- > h1_ "Fading at initial mount"+cssTransitionGroup :: [PropertyOrHandler eventHandler] -> ReactElementM eventHandler a -> ReactElementM eventHandler a #ifdef __GHCJS__-cssTransitionGroup p children = foreignClass js_CSSTransitionGroup props children- where- props = [ "transitionName" @= transitionName p- , "transitionAppear" @= transitionAppear p- , "transitionEnter" @= transitionEnter p- , "transitionLeave" @= transitionLeave p- ]+cssTransitionGroup props children = foreignClass js_CSSTransitionGroup props children foreign import javascript unsafe "React['addons']['CSSTransitionGroup']"
src/React/Flux/DOM.hs view
@@ -189,6 +189,7 @@ node(defs) node(ellipse) node(g)+node(image) node(line) node(linearGradient) node(mask)@@ -327,6 +328,7 @@ defs_ :: Term eventHandler arg result => arg -> result; defs_ = term "defs" ellipse_ :: Term eventHandler arg result => arg -> result; ellipse_ = term "ellipse" g_ :: Term eventHandler arg result => arg -> result; g_ = term "g"+image_ :: Term eventHandler arg result => arg -> result; image_ = term "image" line_ :: Term eventHandler arg result => arg -> result; line_ = term "line" linearGradient_ :: Term eventHandler arg result => arg -> result; linearGradient_ = term "linearGradient" mask_ :: Term eventHandler arg result => arg -> result; mask_ = term "mask"
src/React/Flux/Internal.hs view
@@ -29,11 +29,13 @@ #ifdef __GHCJS__ import Unsafe.Coerce import qualified Data.JSString as JSS+import JavaScript.Array (JSArray) import qualified JavaScript.Array as JSA import GHCJS.Foreign.Callback import qualified JavaScript.Object as JSO import GHCJS.Types (JSRef, JSString, IsJSRef, jsref)-import GHCJS.Marshal (ToJSRef(..), fromJSRef)+import GHCJS.Marshal (ToJSRef(..))+import GHCJS.Foreign (jsNull) import React.Flux.Export #else import Data.Text (Text)@@ -42,7 +44,9 @@ class ToJSRef a instance ToJSRef Value instance ToJSRef Text+instance ToJSRef () class IsJSRef a+type JSArray = JSRef #endif -- type JSObject a = JSO.Object a@@ -71,25 +75,30 @@ { propertyName :: String , propertyVal :: ref }+ | NestedProperty+ { nestedPropertyName :: String+ , nestedPropertyVals :: [PropertyOrHandler handler]+ } | ElementProperty { elementPropertyName :: String , elementValue :: ReactElementM handler () }- | EventHandler- { evtHandlerName :: String- , evtHandler :: HandlerArg -> handler+ | CallbackPropertyWithArgumentArray+ { caPropertyName :: String+ , caFunc :: JSArray -> IO handler }- | CallbackProperty- { callbackName :: String- , callbackFn :: Value -> handler+ | CallbackPropertyWithSingleArgument+ { csPropertyName :: String+ , csFunc :: HandlerArg -> handler } instance Functor PropertyOrHandler where fmap _ (Property name val) = Property name val+ fmap f (NestedProperty name vals) = NestedProperty name (map (fmap f) vals) fmap f (ElementProperty name (ReactElementM mkElem)) = ElementProperty name $ ReactElementM $ mapWriter (\((),e) -> ((), fmap f e)) mkElem- fmap f (EventHandler name h) = EventHandler name (f . h)- fmap f (CallbackProperty name g) = CallbackProperty name (f . g)+ fmap f (CallbackPropertyWithArgumentArray name h) = CallbackPropertyWithArgumentArray name (fmap f . h)+ fmap f (CallbackPropertyWithSingleArgument name h) = CallbackPropertyWithSingleArgument name (f . h) -- | Create a property from anything that can be converted to a JSRef property :: ToJSRef val => String -> val -> PropertyOrHandler handler@@ -245,7 +254,7 @@ [x] -> return x xs -> lift $ do emptyObj <- JSO.create- let arr = JSA.fromList $ map reactElementRef xs+ let arr = jsref $ JSA.fromList $ map reactElementRef xs js_ReactCreateElementName "div" emptyObj arr -- add the property or handler to the javascript object@@ -253,21 +262,27 @@ addPropOrHandlerToObj obj (Property n val) = lift $ do vRef <- toJSRef val JSO.setProp (toJSString n) vRef obj+ addPropOrHandlerToObj obj (NestedProperty n vals) = do+ nested <- lift $ JSO.create+ mapM_ (addPropOrHandlerToObj nested) vals+ lift $ JSO.setProp (toJSString n) (jsref nested) obj addPropOrHandlerToObj obj (ElementProperty name rM) = do ReactElementRef ref <- mToElem rM lift $ JSO.setProp (toJSString name) ref obj- addPropOrHandlerToObj obj (EventHandler str handler) = do+ addPropOrHandlerToObj obj (CallbackPropertyWithArgumentArray name func) = do -- this will be released by the render function of the class (jsbits/class.js)- cb <- lift $ syncCallback1 ContinueAsync $ \evtRef ->- runHandler $ handler $ HandlerArg evtRef- tell [cb]- lift $ JSO.setProp (toJSString str) (jsref cb) obj- addPropOrHandlerToObj obj (CallbackProperty str handler) = do cb <- lift $ syncCallback1 ContinueAsync $ \argref -> do- v <- fromJSRef argref- runHandler $ handler $ maybe (error "Unable to decode callback value") id v+ handler <- func $ unsafeCoerce argref+ runHandler handler tell [cb]- lift $ JSO.setProp (toJSString str) (jsref cb) obj+ wrappedCb <- lift $ js_CreateArgumentsCallback cb+ lift $ JSO.setProp (toJSString name) wrappedCb obj+ addPropOrHandlerToObj obj (CallbackPropertyWithSingleArgument name func) = do+ -- this will be released by the render function of the class (jsbits/class.js)+ cb <- lift $ syncCallback1 ContinueAsync $ \ref ->+ runHandler $ func $ HandlerArg ref+ tell [cb]+ lift $ JSO.setProp (toJSString name) (jsref cb) obj -- call React.createElement createElement :: ReactElement eventHandler -> MkReactElementM [ReactElementRef]@@ -279,20 +294,28 @@ obj <- lift $ JSO.create mapM_ (addPropOrHandlerToObj obj) $ fProps f childNodes <- createElement $ fChild f- let childArr = JSA.fromList $ map reactElementRef childNodes+ let children = case map reactElementRef childNodes of+ [] -> jsNull+ [x] -> x+ xs -> jsref $ JSA.fromList xs e <- lift $ case fName f of- Left s -> js_ReactCreateElementName (toJSString s) obj childArr- Right ref -> js_ReactCreateForeignElement ref obj childArr+ Left s -> js_ReactCreateElementName (toJSString s) obj children+ Right ref -> js_ReactCreateForeignElement ref obj children return [e] createElement (ViewElement { ceClass = rc, ceProps = props, ceKey = mkey, ceChild = child }) = do childNodes <- createElement child propsE <- lift $ export props -- this will be released inside the lifetime events for the class (jsbits/class.js)- let arr = JSA.fromList $ map reactElementRef childNodes++ let children = case map reactElementRef childNodes of+ [] -> jsNull+ [x] -> x+ xs -> jsref $ JSA.fromList xs+ e <- lift $ case mkey of Just key -> do keyRef <- toKeyRef key- js_ReactCreateKeyedElement rc keyRef propsE arr- Nothing -> js_ReactCreateClass rc propsE arr+ js_ReactCreateKeyedElement rc keyRef propsE children+ Nothing -> js_ReactCreateClass rc propsE children return [e] type MkReactElementM a = WriterT [Callback (JSRef -> IO ())] IO a@@ -303,19 +326,23 @@ foreign import javascript unsafe "React['createElement']($1, $2, $3)"- js_ReactCreateElementName :: JSString -> JSO.Object -> JSA.JSArray -> IO ReactElementRef+ js_ReactCreateElementName :: JSString -> JSO.Object -> JSRef -> IO ReactElementRef foreign import javascript unsafe "React['createElement']($1, $2, $3)"- js_ReactCreateForeignElement :: ReactViewRef a -> JSO.Object -> JSA.JSArray -> IO ReactElementRef+ js_ReactCreateForeignElement :: ReactViewRef a -> JSO.Object -> JSRef -> IO ReactElementRef foreign import javascript unsafe "React['createElement']($1, {hs:$2}, $3)"- js_ReactCreateClass :: ReactViewRef a -> Export props -> JSA.JSArray -> IO ReactElementRef+ js_ReactCreateClass :: ReactViewRef a -> Export props -> JSRef -> IO ReactElementRef foreign import javascript unsafe "React['createElement']($1, {key: $2, hs:$3}, $4)"- js_ReactCreateKeyedElement :: ReactViewRef a -> JSRef -> Export props -> JSA.JSArray -> IO ReactElementRef+ js_ReactCreateKeyedElement :: ReactViewRef a -> JSRef -> Export props -> JSRef -> IO ReactElementRef++foreign import javascript unsafe+ "hsreact$mk_arguments_callback($1)"+ js_CreateArgumentsCallback :: Callback (JSRef -> IO ()) -> IO JSRef js_ReactCreateContent :: String -> ReactElementRef js_ReactCreateContent = ReactElementRef . unsafeCoerce . toJSString
src/React/Flux/PropertiesAndEvents.hs view
@@ -1,12 +1,15 @@--- | This module contains the definitions for creating properties to pass to elements, as well as--- the definitions for the+-- | This module contains the definitions for creating properties to pass to javascript elements and+-- foreign javascript classes. In addition, it contains definitions for the -- <https://facebook.github.io/react/docs/events.html React Event System>.+{-# LANGUAGE UndecidableInstances #-} module React.Flux.PropertiesAndEvents ( PropertyOrHandler , (@=) , ($=) , property , elementProperty+ , nestedProperty+ , CallbackFunction , callback -- * Events@@ -17,6 +20,7 @@ , preventDefault , stopPropagation , capturePhase+ , on -- * Keyboard , KeyboardEvent(..)@@ -85,6 +89,7 @@ import React.Flux.Internal import React.Flux.Store+import React.Flux.Views (ViewEventHandler, StatefulViewEventHandler) #ifdef __GHCJS__ import Data.Maybe (fromMaybe)@@ -121,11 +126,63 @@ elementProperty :: String -> ReactElementM handler () -> PropertyOrHandler handler elementProperty = ElementProperty +-- | Allows you to create nested object properties. The list of properties passed in will be+-- converted to an object which is then set as the value for a property with the given name. For+-- example,+--+-- >[ nestedProperty "Hello" [ "a" @= (100 :: Int), "b" $= "World" ]+-- >, "c" $= "!!!"+-- >]+--+-- would create a javascript object+--+-- >{"Hello": {a: 100, b: "World"}, "c": "!!!"}+nestedProperty :: String -> [PropertyOrHandler handler] -> PropertyOrHandler handler+nestedProperty = NestedProperty++-- | A class which is used to implement <https://wiki.haskell.org/Varargs variable argument functions>.+-- Any function where each argument implements 'FromJSRef' and the result is either+-- 'ViewEventHandler' or 'StatefulViewEventHandler' is an instance of this class.+class CallbackFunction handler a | a -> handler where+ applyFromArguments :: JSArray -> Int -> a -> IO handler++instance CallbackFunction ViewEventHandler ViewEventHandler where+ applyFromArguments _ _ h = return h++instance CallbackFunction (StatefulViewEventHandler s) (StatefulViewEventHandler s) where+ applyFromArguments _ _ h = return h++instance (FromJSRef a, CallbackFunction handler b) => CallbackFunction handler (a -> b) where+#if __GHCJS__+ applyFromArguments args k f = do+ ma <- fromJSRef $ if k >= JSA.length args then nullRef else JSA.index k args+ a <- maybe (error "Unable to decode callback argument") return ma+ applyFromArguments args (k+1) $ f a+#else+ applyFromArguments _ _ _ = error "Not supported in GHC"+#endif+ -- | Create a callback property. This is primarily intended for foreign React classes which expect -- callbacks to be passed to them as properties. For events on DOM elements, you should instead use -- the handlers below.-callback :: String -> (A.Value -> handler) -> PropertyOrHandler handler-callback = CallbackProperty+--+-- The function @func@ can be any function, as long as each argument to the function is an instance+-- of 'FromJSRef' and the result of the function is @handler@. Internally, 'callback' creates a+-- javascript function which accesses the @arguments@ javascript object and then matches entries in+-- @arguments@ to the parameters of @func@. If @func@ has more parameters than the javascript+-- @arguments@ object, a javascript null is used for the conversion. Since the 'Maybe' instance of+-- 'FromJSRef' converts a null reference to 'Nothing', you can exploit this to create+-- variable-argument javascript callbacks.+--+-- For example, all three of the following functions could be passed as @func@ inside a view.+--+-- >foo :: Int -> Maybe String -> ViewEventHandler+-- >bar :: Aeson.Value -> ViewEventHandler+-- >baz :: ViewEventHandler+--+-- For another example, see the haddock comments in "React.Flux.Addons.Bootstrap".+callback :: CallbackFunction handler func => String -> func -> PropertyOrHandler handler+callback name func = CallbackPropertyWithArgumentArray name $ \arr -> applyFromArguments arr 0 func ---------------------------------------------------------------------------------------------------- --- Generic Event@@ -184,25 +241,24 @@ , evtHandlerArg = arg } --- | Create an event handler from a name and a handler function.------ This can also be used to pass in arbitrary callbacks to foreign javascript React classes.--- Indeed, what 'on' does is create a callback and then add a property with key the string passed to--- 'on' and value the callback.-on :: String -> (HandlerArg -> handler) -> PropertyOrHandler handler-on = EventHandler+-- | Use this to create an event handler for an event not covered by the rest of this module. At+-- the moment, this is just the media events (onPlay, onPause, etc.) on image and video tags.+on :: String -> (Event -> handler) -> PropertyOrHandler handler+on name f = CallbackPropertyWithSingleArgument+ { csPropertyName = name+ , csFunc = f . parseEvent+ } -- | Construct a handler from a detail parser, used by the various events below.-mkHandler :: String -- ^ The event name- -> (HandlerArg -> detail) -- ^ A function parsing the details for the specific event.- -> (Event -> detail -> handler) -- ^ The function implementing the handler.- -> PropertyOrHandler handler-mkHandler name parseDetail f = EventHandler- { evtHandlerName = name- , evtHandler = \raw -> f (parseEvent raw) (parseDetail raw)+on2 :: String -- ^ The event name+ -> (HandlerArg -> detail) -- ^ A function parsing the details for the specific event.+ -> (Event -> detail -> handler) -- ^ The function implementing the handler.+ -> PropertyOrHandler handler+on2 name parseDetail f = CallbackPropertyWithSingleArgument+ { csPropertyName = name+ , csFunc = \raw -> f (parseEvent raw) (parseDetail raw) } - -- | In a hack, the prevent default and stop propagation are actions since that is the easiest way -- of allowing users to specify these actions (IO is not available in view event handlers). We -- create a fake store to handle these actions.@@ -262,7 +318,7 @@ -- | By default, the handlers below are triggered during the bubbling phase. Use this to switch -- them to trigger during the capture phase. capturePhase :: PropertyOrHandler handler -> PropertyOrHandler handler-capturePhase (EventHandler n h) = EventHandler (n ++ "Capture") h+capturePhase (CallbackPropertyWithSingleArgument n h) = CallbackPropertyWithSingleArgument (n ++ "Capture") h capturePhase _ = error "You must use React.Flux.PropertiesAndEvents.capturePhase on an event handler" ---------------------------------------------------------------------------------------------------@@ -311,13 +367,13 @@ } onKeyDown :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler-onKeyDown = mkHandler "onKeyDown" parseKeyboardEvent+onKeyDown = on2 "onKeyDown" parseKeyboardEvent onKeyPress :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler-onKeyPress = mkHandler "onKeyPress" parseKeyboardEvent+onKeyPress = on2 "onKeyPress" parseKeyboardEvent onKeyUp :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler-onKeyUp = mkHandler "onKeyUp" parseKeyboardEvent+onKeyUp = on2 "onKeyUp" parseKeyboardEvent -------------------------------------------------------------------------------- -- Focus Events@@ -331,10 +387,10 @@ parseFocusEvent (HandlerArg ref) = FocusEvent $ EventTarget $ js_getProp ref "relatedTarget" onBlur :: (Event -> FocusEvent -> handler) -> PropertyOrHandler handler-onBlur = mkHandler "onBlur" parseFocusEvent+onBlur = on2 "onBlur" parseFocusEvent onFocus :: (Event -> FocusEvent -> handler) -> PropertyOrHandler handler-onFocus = mkHandler "onFocus" parseFocusEvent+onFocus = on2 "onFocus" parseFocusEvent -------------------------------------------------------------------------------- -- Form Events@@ -343,13 +399,13 @@ -- | The onChange event is special in React and should be used for all input change events. For -- details, see <https://facebook.github.io/react/docs/forms.html> onChange :: (Event -> handler) -> PropertyOrHandler handler-onChange f = on "onChange" (f . parseEvent)+onChange = on "onChange" onInput :: (Event -> handler) -> PropertyOrHandler handler-onInput f = on "onInput" (f . parseEvent)+onInput = on "onInput" onSubmit :: (Event -> handler) -> PropertyOrHandler handler-onSubmit f = on "onSubmit" (f . parseEvent)+onSubmit = on "onSubmit" -------------------------------------------------------------------------------- -- Mouse Events@@ -395,66 +451,67 @@ } onClick :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onClick = mkHandler "onClick" parseMouseEvent+onClick = on2 "onClick" parseMouseEvent onContextMenu :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onContextMenu = mkHandler "onContextMenu" parseMouseEvent+onContextMenu = on2 "onContextMenu" parseMouseEvent onDoubleClick :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDoubleClick = mkHandler "onDoubleClick" parseMouseEvent+onDoubleClick = on2 "onDoubleClick" parseMouseEvent onDrag :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDrag = mkHandler "onDrag" parseMouseEvent+onDrag = on2 "onDrag" parseMouseEvent onDragEnd :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDragEnd = mkHandler "onDragEnd" parseMouseEvent+onDragEnd = on2 "onDragEnd" parseMouseEvent onDragEnter :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDragEnter = mkHandler "onDragEnter" parseMouseEvent+onDragEnter = on2 "onDragEnter" parseMouseEvent onDragExit :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDragExit = mkHandler "onDragExit" parseMouseEvent+onDragExit = on2 "onDragExit" parseMouseEvent onDragLeave :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDragLeave = mkHandler "onDragLeave" parseMouseEvent+onDragLeave = on2 "onDragLeave" parseMouseEvent onDragOver :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDragOver = mkHandler "onDragOver" parseMouseEvent+onDragOver = on2 "onDragOver" parseMouseEvent onDragStart :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDragStart = mkHandler "onDragStart" parseMouseEvent+onDragStart = on2 "onDragStart" parseMouseEvent onDrop :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onDrop = mkHandler "onDrop" parseMouseEvent+onDrop = on2 "onDrop" parseMouseEvent onMouseDown :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseDown = mkHandler "onMouseDown" parseMouseEvent+onMouseDown = on2 "onMouseDown" parseMouseEvent onMouseEnter :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseEnter = mkHandler "onMouseEnter" parseMouseEvent+onMouseEnter = on2 "onMouseEnter" parseMouseEvent onMouseLeave :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseLeave = mkHandler "onMouseLeave" parseMouseEvent+onMouseLeave = on2 "onMouseLeave" parseMouseEvent onMouseMove :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseMove = mkHandler "onMouseMove" parseMouseEvent+onMouseMove = on2 "onMouseMove" parseMouseEvent onMouseOut :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseOut = mkHandler "onMouseOut" parseMouseEvent+onMouseOut = on2 "onMouseOut" parseMouseEvent onMouseOver :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseOver = mkHandler "onMouseOver" parseMouseEvent+onMouseOver = on2 "onMouseOver" parseMouseEvent onMouseUp :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler-onMouseUp = mkHandler "onMouseUp" parseMouseEvent+onMouseUp = on2 "onMouseUp" parseMouseEvent -------------------------------------------------------------------------------- -- Touch -------------------------------------------------------------------------------- +-- | Initialize touch events is only needed with React 0.13, in version 0.14 it was removed. #ifdef __GHCJS__ foreign import javascript unsafe- "React['initializeTouchEvents'](true)"+ "React['initializeTouchEvents'] ? React['initializeTouchEvents'](true) : null" initializeTouchEvents :: IO () #else initializeTouchEvents :: IO ()@@ -519,23 +576,23 @@ } onTouchCancel :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler-onTouchCancel = mkHandler "onTouchCancel" parseTouchEvent+onTouchCancel = on2 "onTouchCancel" parseTouchEvent onTouchEnd :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler-onTouchEnd = mkHandler "onTouchEnd" parseTouchEvent+onTouchEnd = on2 "onTouchEnd" parseTouchEvent onTouchMove :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler-onTouchMove = mkHandler "onTouchMove" parseTouchEvent+onTouchMove = on2 "onTouchMove" parseTouchEvent onTouchStart :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler-onTouchStart = mkHandler "onTouchStart" parseTouchEvent+onTouchStart = on2 "onTouchStart" parseTouchEvent -------------------------------------------------------------------------------- -- UI Events -------------------------------------------------------------------------------- onScroll :: (Event -> handler) -> PropertyOrHandler handler-onScroll f = on "onScroll" (f . parseEvent)+onScroll = on "onScroll" -------------------------------------------------------------------------------- -- Wheel@@ -557,9 +614,9 @@ } onWheel :: (Event -> MouseEvent -> WheelEvent -> handler) -> PropertyOrHandler handler-onWheel f = EventHandler- { evtHandlerName = "onWheel"- , evtHandler = \raw -> f (parseEvent raw) (parseMouseEvent raw) (parseWheelEvent raw)+onWheel f = CallbackPropertyWithSingleArgument+ { csPropertyName = "onWheel"+ , csFunc = \raw -> f (parseEvent raw) (parseMouseEvent raw) (parseWheelEvent raw) } --------------------------------------------------------------------------------@@ -567,10 +624,10 @@ -------------------------------------------------------------------------------- onLoad :: (Event -> handler) -> PropertyOrHandler handler-onLoad f = on "onLoad" (f . parseEvent)+onLoad = on "onLoad" onError :: (Event -> handler) -> PropertyOrHandler handler-onError f = on "onError" (f . parseEvent)+onError = on "onError" -------------------------------------------------------------------------------- --- JS Utils@@ -584,7 +641,7 @@ foreign import javascript unsafe "$1[$2]"- js_getArrayProp :: JSRef -> JSString -> JSA.JSArray+ js_getArrayProp :: JSRef -> JSString -> JSArray -- | Access a property from an object. Since event objects are immutable, we can use -- unsafePerformIO without worry.
src/React/Flux/Store.hs view
@@ -28,7 +28,7 @@ instance IsJSRef (ReactStoreRef storeData) -- | A store contains application state, receives actions from the dispatcher, and notifies--- component views to re-render themselves. You can have multiple stores; it should be the case+-- controller-views to re-render themselves. You can have multiple stores; it should be the case -- that all of the state required to render the page is contained in the stores. A store keeps a -- global reference to a value of type @storeData@, which must be an instance of 'StoreData'. --
src/React/Flux/Views.hs view
@@ -185,7 +185,7 @@ -- | A stateful view is a re-usable component of the page which keeps track of internal state. -- Try to keep as many views as possible stateless. The React documentation on--- <https://facebook.github.io/react/docs/interactivity-and-dynamic-uis.html inteactivity and dynamic UIs>+-- <https://facebook.github.io/react/docs/interactivity-and-dynamic-uis.html interactivity and dynamic UIs> -- has some discussion of what should and should not go into the state. -- -- The rendering function is a pure function of the state and the properties from the parent. The@@ -285,19 +285,22 @@ js_ReactGetProps :: ReactThis state props -> IO (Export props) foreign import javascript unsafe- "$1['props']['children']"- js_ReactGetChildren :: ReactThis state props -> IO (JSArray)+ "hsreact$children_to_array($1['props']['children'])"+ js_ReactGetChildren :: ReactThis state props -> IO JSArray foreign import javascript unsafe "$1._updateAndReleaseState($2)" js_ReactUpdateAndReleaseState :: ReactThis state props -> Export state -> IO () +-- React 0.13 has React.findDOMNode, while 0.14 moves it to ReactDOM.findDOMNode. Also, 0.14+-- does not need to call findDOMNode on refs.+ foreign import javascript unsafe- "React['findDOMNode']($1)"+ "typeof ReactDOM === 'object' ? ReactDOM['findDOMNode']($1) : React['findDOMNode']($1)" js_ReactFindDOMNode :: ReactThis state props -> IO JSRef foreign import javascript unsafe- "React['findDOMNode']($1['refs'][$2])"+ "typeof ReactDOM === 'object' ? $1['refs'][$2] : React['findDOMNode']($1['refs'][$2])" js_ReactGetRef :: ReactThis state props -> JSString -> IO JSRef newtype RenderCbArg = RenderCbArg JSRef@@ -348,8 +351,7 @@ node <- render state props let getPropsChildren = do childRef <- js_ReactGetChildren this- let childArr = toList childRef- return $ map ReactElementRef childArr+ return $ map ReactElementRef $ toList childRef (element, evtCallbacks) <- mkReactElement (runHandler this) getPropsChildren node
test/client/TestClient.hs view
@@ -1,21 +1,22 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-module Main where+{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables, DeriveAnyClass, FlexibleInstances, DeriveGeneric #-}+module TestClient (testClient) where +import Control.DeepSeq (NFData) import Control.Monad+import Data.Monoid ((<>)) import Data.Typeable (Typeable) import Data.Maybe import Debug.Trace+import GHC.Generics (Generic) import React.Flux import React.Flux.Lifecycle import React.Flux.Internal (toJSString)+import React.Flux.Addons.React+import React.Flux.Addons.Bootstrap import GHCJS.Types (JSRef, JSString) import GHCJS.Marshal (fromJSRef) --- TODO: --- * Addons--- * callback property- foreign import javascript unsafe "(function(x) { \ \ if (!window.test_client_output) window.test_client_output = []; \@@ -105,7 +106,7 @@ ] "Testing preventDefault" - p_ $+ div_ $ div_ [ "id" $= "outer-div" , onClick $ \_ _ -> output ["Click on outer div"] , capturePhase $ onDoubleClick $ \e _ -> output ["Double click outer div"] ++ [stopPropagation e]@@ -156,7 +157,6 @@ button_ [ "id" $= "increment-state" , onClick $ \_ _ st -> ([], Just $ st + 1) ] "Incr"- div_ childrenPassedToView , lComponentWillMount = Just $ \pAndS setStateFn -> do outputIO ["will mount"]@@ -192,14 +192,114 @@ testLifecycle_ s = view testLifecycle s $ span_ ["id" $= "child-passed-to-view"] "I am a child!!!" --------------------------------------------------------------------------------+--- Children passed to view+--------------------------------------------------------------------------------++displayChildren :: ReactView String+displayChildren = defineView "display children" $ \ident ->+ span_ ["className" $= "display-children", "id" @= ident] childrenPassedToView++displayChildren_ :: String -> ReactElementM handler () -> ReactElementM handler ()+displayChildren_ = view displayChildren++displayChildrenSpec :: ReactElementM handler ()+displayChildrenSpec = ul_ $ do+ li_ $ displayChildren_ "empty-children" mempty+ li_ $ displayChildren_ "single-child-wrapper" $ span_ ["id" $= "single-child"] "Single Child!!"+ li_ $ displayChildren_ "multi-child" $ span_ ["id" $= "child1"] "Child 1" <> span_ ["id" $= "child2"] "Child 2"++--------------------------------------------------------------------------------+--- CSS Transitions+--------------------------------------------------------------------------------++cssTransitions :: ReactView [String]+cssTransitions = defineView "css transitions" $ \items ->+ div_ ["id" $= "css-transitions"] $+ cssTransitionGroup ["transitionName" $= "example"] $+ forM_ (zip items [(0 :: Int)..]) $ \(txt, key) ->+ div_ ["key" @= key] $ span_ ["className" $= "css-transition-entry"] $ elemText txt++--------------------------------------------------------------------------------+--- Bootstrap+--------------------------------------------------------------------------------++bootstrapSpec :: ReactView ()+bootstrapSpec = defineView "bootstrap" $ \() -> div_ ["id" $= "bootstrap"] $ do+ bootstrap_ "Alert" [ "bsStyle" $= "danger"+ , callback "onDismiss" $ output ["Closing alert"]+ ] $+ p_ "Hello, World!"++ bootstrap_ "Nav" [ "activeKey" @= (1 :: Int)+ , callback "onSelect" $ \(i :: Int) -> output ["Switched to " ++ show i]+ ] $ do+ bootstrap_ "NavItem" ["eventKey" @= (1 :: Int)] "Item 1"+ bootstrap_ "NavItem" ["eventKey" @= (2 :: Int)] "Item 2"+ bootstrap_ "NavItem" ["eventKey" @= (3 :: Int)] "Item 3"++--------------------------------------------------------------------------------+--- shouldComponentUpdate+--------------------------------------------------------------------------------++data ShouldComponentUpdateData = ShouldComponentUpdateData Int String+ deriving (Typeable, Show)++data ShouldComponentUpdateAction = IncrementAllSCUData+ | IncrementFirstSCUData+ | NoChangeToSCUData+ deriving (Show, Typeable, Generic, NFData)++instance StoreData [ShouldComponentUpdateData] where+ type StoreAction [ShouldComponentUpdateData] = ShouldComponentUpdateAction+ transform NoChangeToSCUData s = return s+ transform IncrementAllSCUData d = return [ShouldComponentUpdateData (i+1) s | ShouldComponentUpdateData i s <- d]+ transform IncrementFirstSCUData (ShouldComponentUpdateData i s:xs) = return $ (ShouldComponentUpdateData (i+1) s) : xs+ transform _ [] = error "Should never happen"++shouldComponentUpdateStore :: ReactStore [ShouldComponentUpdateData]+shouldComponentUpdateStore = mkStore [ ShouldComponentUpdateData 1 "Hello"+ , ShouldComponentUpdateData 2 "World"+ , ShouldComponentUpdateData 3 "!!!"+ ]++-- | This will log wheenver componentWillUpdate lifecycle event occurs+logComponentWillUpdate :: ReactView ShouldComponentUpdateData+logComponentWillUpdate = defineLifecycleView "shouldComponentUpdate spec" () lifecycleConfig+ { lRender = \() (ShouldComponentUpdateData i s) ->+ span_ (elemShow i) <> span_ (elemText s)+ , lComponentWillUpdate = Just $ \curProps _ (ShouldComponentUpdateData newI newS) () -> do+ ShouldComponentUpdateData curI curS <- lGetProps curProps+ outputIO [ "Component will update"+ , "current props: " ++ show curI ++ " " ++ curS+ , "new props: " ++ show newI ++ " " ++ newS+ ]+ }++shouldComponentUpdateSpec :: ReactView ()+shouldComponentUpdateSpec = defineControllerView "should component update" shouldComponentUpdateStore $ \ds () -> + div_ ["id" $= "should-component-update"] $ do+ ul_ $ forM_ (zip ds [(0 :: Int)..]) $ \(su, i) ->+ li_ $ viewWithKey logComponentWillUpdate i su mempty++ button_ ["id" $= "no-change-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore NoChangeToSCUData]]+ "No change to data"++ button_ ["id" $= "change-all-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore IncrementAllSCUData]]+ "Increment all"++ button_ ["id" $= "increment-first-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore IncrementFirstSCUData]]+ "Increment first entry's integer"++-------------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------------- -- | Test a lifecycle view with all lifecycle methods nothing-app :: ReactView ()-app = defineLifecycleView "app" "Hello" lifecycleConfig+testClient :: ReactView ()+testClient = defineLifecycleView "app" "Hello" lifecycleConfig { lRender = \s () -> do eventsView_+ when (s /= "") $ testLifecycle_ s button_ [ "id" $= "add-app-str"@@ -209,9 +309,12 @@ button_ [ "id" $= "clear-app-str" , onClick $ \_ _ _ -> ([], Just "") ] "Clear"- } -main :: IO ()-main = do- initializeTouchEvents- reactRender "app" app ()+ displayChildrenSpec++ view cssTransitions ["A", "B"] mempty++ view bootstrapSpec () mempty++ view shouldComponentUpdateSpec () mempty+ }
+ test/client/TestClient13.hs view
@@ -0,0 +1,9 @@+module Main (main) where++import TestClient+import React.Flux++main :: IO ()+main = do+ initializeTouchEvents+ reactRender "app" testClient ()
+ test/client/TestClient14.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables, TemplateHaskell #-}+module Main (main) where++import Data.Time+import React.Flux+import React.Flux.Addons.Intl+import GHCJS.Types (JSRef)++import TestClient++--------------------------------------------------------------------------------+--- Intl+--------------------------------------------------------------------------------++foreign import javascript unsafe+ "{'with_trans': 'message from translation {abc}'}"+ js_translations :: JSRef++intlSpec :: ReactView ()+intlSpec = defineView "intl" $ \() -> div_ ["id" $= "intl-spec"] $ intlProvider_ "en-US" (Just js_translations) Nothing $+ ul_ $ do+ li_ ["id" $= "f-number"] $+ formattedNumber_ [ "value" @= (0.9 :: Double), "style" $= "percent" ]+ li_ ["id" $= "f-int"] $ int_ 100000+ li_ ["id" $= "f-double"] $ double_ 40000.2++ let moon = fromGregorian 1969 7 20+ fullDayF = DayFormat { weekdayF = Just "long", eraF = Just "short", yearF = Just "2-digit", monthF = Just "long", dayF = Just "2-digit" }++ li_ ["id" $= "f-shortday"] $ day_ shortDate moon+ li_ ["id" $= "f-fullday"] $ day_ fullDayF moon+ li_ ["id" $= "f-date"] $ formattedDate_ (Left moon)+ [ "weekday" $= "short", "month" $= "short", "day" $= "numeric", "year" $= "2-digit" ]++ let step = UTCTime moon (2*60*60 + 56*60) -- 1969-7-20 02:56 UTC+ fullT = (fullDayF, TimeFormat { hourF = Just "numeric", minuteF = Just "2-digit", secondF = Just "numeric", timeZoneNameF = Just "long" })+ + li_ ["id" $= "f-shorttime"] $ utcTime_ shortDateTime step+ li_ ["id" $= "f-fulltime"] $ utcTime_ fullT step+ li_ ["id" $= "f-time"] $ formattedDate_ (Right step)+ [ "year" $= "2-digit", "month" $= "short", "day" $= "numeric"+ , "hour" $= "numeric", "minute" $= "2-digit", "second" $= "numeric"+ , "timeZoneName" $= "short"+ , "timeZone" $= "Pacific/Tahiti"+ ]++ {-+ li_ ["id" $= "f-relative"] $ relativeTo_ step+ li_ ["id" $= "f-relative-days"] $ formattedRelative_ step [ "units" $= "day" ]+ -}++ li_ ["id" $= "f-plural"] $ plural_ [ "value" @= (100 :: Int), "one" $= "plural one", "other" $= "plural other"]++ li_ ["id" $= "f-msg"] $+ $(message "photos" "{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}} {takenAgo}.")+ [ "name" $= "Neil Armstrong"+ , "numPhotos" @= (100 :: Int)+ , elementProperty "takenAgo" $ span_ ["id" $= "takenAgoSpan"] "years ago"+ ]++ li_ ["id" $= "f-msg-with-trans"] $+ $(message "with_trans" "this is not used {abc}") ["abc" $= "xxx"]++ li_ ["id" $= "f-msg-with-descr"] $+ $(message' "photos2" "How many photos?" "{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}}.")+ [ "name" $= "Neil Armstrong"+ , "numPhotos" @= (0 :: Int)+ ]++ li_ ["id" $= "f-html-msg"] $+ $(htmlMsg "html1" "<b>{num}</b> is the answer to life, the universe, and everything")+ [ "num" @= (42 :: Int) ]++ li_ ["id" $= "f-html-msg-with-descr"] $+ $(htmlMsg' "html2" "Hitchhiker's Guide" "{num} is the <b>answer</b> to life, the universe, and everything")+ [ "num" @= (42 :: Int) ]++--------------------------------------------------------------------------------+--- Main+--------------------------------------------------------------------------------++-- | Test a lifecycle view with all lifecycle methods nothing+app :: ReactView ()+app = defineView "main app" $ \() -> do+ view testClient () mempty+ view intlSpec () mempty++main :: IO ()+main = reactRender "app" app ()++writeIntlMessages (intlFormatJson "test/client/msgs/jsonmsgs.json")+writeIntlMessages (intlFormatJsonWithoutDescription "test/client/msgs/jsonnodescr.json")+writeIntlMessages (intlFormatAndroidXML "test/client/msgs/android.xml")
+ test/client/msgs/android.xml view
@@ -0,0 +1,10 @@+<?xml version="1.0" encoding="utf-8"?>+<resources>+<string name="html1"><b>{num}</b> is the answer to life, the universe, and everything</string>+<!-- Hitchhiker's Guide -->+<string name="html2">{num} is the <b>answer</b> to life, the universe, and everything</string>+<string name="photos">{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}} {takenAgo}.</string>+<!-- How many photos? -->+<string name="photos2">{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}}.</string>+<string name="with_trans">this is not used {abc}</string>+</resources>
+ test/client/msgs/jsonmsgs.json view
@@ -0,0 +1,1 @@+{"photos":{"message":"{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}} {takenAgo}."},"html2":{"message":"{num} is the <b>answer</b> to life, the universe, and everything","description":"Hitchhiker's Guide"},"photos2":{"message":"{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}}.","description":"How many photos?"},"html1":{"message":"<b>{num}</b> is the answer to life, the universe, and everything"},"with_trans":{"message":"this is not used {abc}"}}
+ test/client/msgs/jsonnodescr.json view
@@ -0,0 +1,1 @@+{"photos":"{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}} {takenAgo}.","html2":"{num} is the <b>answer</b> to life, the universe, and everything","photos2":"{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}}.","html1":"<b>{num}</b> is the answer to life, the universe, and everything","with_trans":"this is not used {abc}"}
− test/client/test-client.html
@@ -1,10 +0,0 @@-<html>- <head>- <title>Test Client</title>- </head>- <body>- <div id="app"></div>- <script src="https://fb.me/react-with-addons-0.13.3.js"></script>- <script src="../../dist/build/test-client/test-client.jsexe/all.js"></script>- </body>-</html>
+ test/client/test-client13.html view
@@ -0,0 +1,12 @@+<html>+ <head>+ <title>Test Client</title>+ </head>+ <body>+ <div id="app"></div>+ <script src="https://fb.me/react-with-addons-0.13.3.js"></script>+ <script src="node_modules/react-intl/dist/react-intl.js"></script>+ <script src="https://cdnjs.cloudflare.com/ajax/libs/react-bootstrap/0.25.2/react-bootstrap.min.js"></script>+ <script src="../../dist/build/test-client-13/test-client-13.jsexe/all.js"></script>+ </body>+</html>
+ test/client/test-client14.html view
@@ -0,0 +1,13 @@+<html>+ <head>+ <title>Test Client</title>+ </head>+ <body>+ <div id="app"></div>+ <script src="https://fb.me/react-with-addons-0.14.0-rc1.js"></script>+ <script src=" https://fb.me/react-dom-0.14.0-rc1.js"></script>+ <script src="node_modules/react-intl/dist/react-intl.js"></script>+ <script src="https://cdnjs.cloudflare.com/ajax/libs/react-bootstrap/0.25.2/react-bootstrap.min.js"></script>+ <script src="../../dist/build/test-client-14/test-client-14.jsexe/all.js"></script>+ </body>+</html>
+ test/spec/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.Hspec+import System.Process+import qualified Spec++main :: IO ()+main = do+ _ <- system "cd ../../example/todo && make"+ hspec Spec.spec
test/spec/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
test/spec/TestClientSpec.hs view
@@ -5,6 +5,7 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.List+--import Data.Time import qualified Data.Text as T import System.Directory (getCurrentDirectory) import Test.Hspec.WebDriver@@ -34,11 +35,37 @@ p <- findElem (ById "world") getText p `shouldReturn` (T.pack $ "Current props: " ++ props) +scuShouldBe :: [(Int, String)] -> WD ()+scuShouldBe items = do+ d <- findElem $ ById "should-component-update"+ lis <- findElemsFrom d $ ByTag "li"+ length lis `shouldBe` length items+ forM_ (zip lis items) $ \(li,(i, s)) ->+ getText li `shouldReturn` (T.pack $ show i ++ s)++intlSpanShouldBe :: String -> String -> WD ()+intlSpanShouldBe ident txt = do+ e <- findElem (ById $ T.pack ident)+ getText e `shouldReturn` T.pack txt++-- | Only up to 999,999 since this is just used for the number of days since 1969+showWithComma :: Integer -> String+showWithComma i = show x ++ "," ++ show y+ where+ (x, y) = divMod i 1000+ spec :: Spec-spec = session " for the test client" $ using Chrome $ do+spec = do+ describe "React 0.13" $ testClientSpec "test-client13.html"+ describe "React 0.14" $ do+ testClientSpec "test-client14.html"+ intlSpec "test-client14.html"++testClientSpec :: String -> Spec+testClientSpec filename = session " for the test client" $ using Chrome $ do it "opens the page" $ runWD $ do dir <- liftIO $ getCurrentDirectory- openPage $ "file://" ++ dir ++ "/../client/test-client.html"+ openPage $ "file://" ++ dir ++ "/../client/" ++ filename loadLog `shouldReturn` [ "will mount" , "Current props and state: Hello, 12"@@ -49,8 +76,6 @@ , "refProps id = world" ] lifecyclePropsAndStateAre "Hello" 100- child <- findElem (ById "child-passed-to-view")- isDisplayed child `shouldReturn` True it "processes a focus event" $ runWD $ do findElem (ById "keyinput") >>= click@@ -158,8 +183,136 @@ , "Current props and state: Helloo, 101" ] + describe "children passed to view" $ do++ it "does not display null children" $ runWD $ do+ s <- findElem $ ById "empty-children"+ findElemsFrom s (ByCSS "*") `shouldReturn` []+ getText s `shouldReturn` ""++ it "displays a single child" $ runWD $ do+ s <- findElem $ ById "single-child-wrapper"+ s' <- findElemFrom s $ ByCSS "span#single-child"+ getText s' `shouldReturn` "Single Child!!"++ it "displays a child list" $ runWD $ do+ s <- findElem $ ById "multi-child"+ c1 <- findElemFrom s $ ByCSS "span#child1"+ getText c1 `shouldReturn` "Child 1"+ c2 <- findElemFrom s $ ByCSS "span#child2"+ getText c2 `shouldReturn` "Child 2"++ it "displays the elements inside the transition" $ runWD $ do+ d <- findElem $ ById "css-transitions"+ [a, b] <- findElemsFrom d $ ByCSS "span.css-transition-entry"+ getText a `shouldReturn` "A"+ getText b `shouldReturn` "B"++ describe "bootstrap" $ do++ it "displays and closes alert" $ runWD $ do+ alert <- findElem $ ByCSS "div#bootstrap div.alert"+ (findElemFrom alert (ByTag "p") >>= getText)+ `shouldReturn` "Hello, World!"+ findElemFrom alert (ByTag "button") >>= click+ loadLog `shouldReturn` ["Closing alert"]++ it "switchs nav items" $ runWD $ do+ navUl <- findElem $ ByCSS "div#bootstrap nav > ul"+ i1 <- findElemFrom navUl $ ByCSS "li:first-child a"+ i2 <- findElemFrom navUl $ ByCSS "li:nth-child(2) a"+ i3 <- findElemFrom navUl $ ByCSS "li:nth-child(3) a"+ click i2+ loadLog `shouldReturn` ["Switched to 2"]+ click i3+ loadLog `shouldReturn` ["Switched to 3"]+ click i1+ loadLog `shouldReturn` ["Switched to 1"]++ describe "should component update" $ do++ it "has the initial data" $ runWD $+ scuShouldBe [(1, "Hello"), (2, "World"), (3, "!!!")]++ it "increments just the first entry without re-rendering all entries" $ runWD $ do+ findElem (ById "increment-first-scu") >>= click+ scuShouldBe [(2, "Hello"), (2, "World"), (3, "!!!")]+ loadLog `shouldReturn`+ [ "Component will update"+ , "current props: 1 Hello"+ , "new props: 2 Hello"+ ]++ it "does not update when no change to data" $ runWD $ do+ findElem (ById "no-change-scu") >>= click+ scuShouldBe [(2, "Hello"), (2, "World"), (3, "!!!")]+ loadLog `shouldReturn` []++ it "increments all entries" $ runWD $ do+ findElem (ById "change-all-scu") >>= click+ scuShouldBe [(3, "Hello"), (3, "World"), (4, "!!!")]+ loadLog `shouldReturn`+ [ "Component will update"+ , "current props: 2 Hello"+ , "new props: 3 Hello"+ , "Component will update"+ , "current props: 2 World"+ , "new props: 3 World"+ , "Component will update"+ , "current props: 3 !!!"+ , "new props: 4 !!!"+ ]++ {- it "inspects the session" $ runWD $ do loadLog >>= \x -> liftIO $ putStrLn $ show x inspectSession -}++intlSpec :: String -> Spec+intlSpec filename = session " for the i18n test client" $ using Chrome $ do+ it "opens the page" $ runWD $ do+ dir <- liftIO $ getCurrentDirectory+ openPage $ "file://" ++ dir ++ "/../client/" ++ filename++ it "displays the intl formatted data" $ runWD $ do+ "f-number" `intlSpanShouldBe` "90%"+ "f-int" `intlSpanShouldBe` "100,000"+ "f-double" `intlSpanShouldBe` "40,000.2"+ "f-shortday" `intlSpanShouldBe` "Jul 20, 1969"+ "f-fullday" `intlSpanShouldBe` "Sunday, July 20, 69 AD"+ "f-date" `intlSpanShouldBe` "Sun, Jul 20, 69"+ -- f-shorttime and f-fulltime cannot be (easily) tested since they rely on the current timezone+ "f-time" `intlSpanShouldBe` "Jul 19, 69, 4:56:00 PM GMT-10"+ "f-plural" `intlSpanShouldBe` "plural other"++ {-+ today <- liftIO (utctDay <$> getCurrentTime)+ let moon = fromGregorian 1969 7 20+ daysAgo = diffDays today moon+ yearsAgo :: Int = round $ realToFrac daysAgo / (365 :: Double) -- is close enough+ "f-relative" `intlSpanShouldBe` (show yearsAgo ++ " years ago")+ "f-relative-days" `intlSpanShouldBe` (showWithComma daysAgo ++ " days ago")+ -}++ it "displays messages" $ runWD $ do+ msg <- findElem $ ById "f-msg"+ getText msg `shouldReturn` "Neil Armstrong took 100 photos years ago."+ takenAgoSpan <- findElemFrom msg $ ById "takenAgoSpan"+ getText takenAgoSpan `shouldReturn` "years ago"++ msg' <- findElem $ ById "f-msg-with-descr"+ getText msg' `shouldReturn` "Neil Armstrong took no photos."++ "f-msg-with-trans" `intlSpanShouldBe` "message from translation xxx"++ htmlMsg <- findElem $ ById "f-html-msg"+ getText htmlMsg `shouldReturn` "42 is the answer to life, the universe, and everything"+ (findElemFrom htmlMsg (ByTag "b") >>= getText)+ `shouldReturn` "42"++ htmlMsg' <- findElem $ ById "f-html-msg-with-descr"+ getText htmlMsg' `shouldReturn` "42 is the answer to life, the universe, and everything"+ (findElemFrom htmlMsg' (ByTag "b") >>= getText)+ `shouldReturn` "answer"
test/spec/TodoSpec.hs view
@@ -16,7 +16,7 @@ forM_ (zip entries todos) $ \(li, (todo, complete)) -> do chk <- findElemFrom li $ ByCSS "input[type=checkbox]" attr chk "checked" `shouldReturn` if complete then Just "true" else Nothing- spn <- findElemFrom li $ ByTag "span"+ spn <- findElemFrom li $ ByTag "label" getText spn `shouldReturn` todo -- check items left@@ -30,7 +30,7 @@ -- clear completed let completedCnt = length $ filter snd todos when (completedCnt > 0) $ do- completeBtn <- findElem $ ByCSS "button#clear-completed span"+ completeBtn <- findElem $ ByCSS "button#clear-completed" getText completeBtn `shouldReturn` (T.pack $ "Clear completed (" ++ show completedCnt ++ ")") getRow :: Int -> WD Element@@ -58,7 +58,7 @@ it "edits a todo" $ runWD $ do midRow <- getRow 1- findElemFrom midRow (ByTag "span") >>= moveToCenter+ findElemFrom midRow (ByTag "label") >>= moveToCenter doubleClick editBox <- findElemFrom midRow (ByCSS "input.edit") sendKeys "Learn react.js" editBox
test/spec/react-flux-spec.cabal view
@@ -6,12 +6,14 @@ executable react-flux-spec ghc-options: -Wall hs-source-dirs: .- main-is: Spec.hs- other-modules: TodoSpec, TestClientSpec+ main-is: Main.hs+ other-modules: TodoSpec, TestClientSpec, Spec build-depends: base , hspec , webdriver , hspec-webdriver , directory+ , process , transformers , text+ , time
test/spec/stack.yaml view
@@ -1,3 +1,3 @@-resolver: lts-3.2+resolver: lts-3.6 packages: - '.'